Adding LAPACK and compilation process

295 files changed, 91067 insertions, 0 deletions

diff --git a/src/lib/lapack/Makefile.am b/src/lib/lapack/Makefile.am
new file mode 100644
index 00000000..ea078406
--- /dev/null
+++ b/src/lib/lapack/Makefile.am
@@ -0,0 +1,320 @@
+##########
+### Sylvestre Ledru <sylvestre.ledru@inria.fr>
+### INRIA - Scilab 2006
+##########
+
+#### Target ######
+modulename=lapack
+
+pkglib_LTLIBRARIES = libscilapack.la
+
+noinst_LTLIBRARIES = libdummy-lapack.la
+
+LAPACK_FORTRAN_SOURCES = dlasv2.f \
+zgeqpf.f \
+zrot.f \
+dpotrf.f \
+zunmr3.f \
+zlanhs.f \
+zgebak.f \
+zbdsqr.f \
+zunmrz.f \
+dgetc2.f \
+zlaqp2.f \
+dsytrd.f \
+dsytd2.f \
+zlange.f \
+dlansp.f \
+dhgeqz.f \
+dlasq2.f \
+dtrevc.f \
+dgelsy.f \
+zladiv.f \
+dlaswp.f \
+dormlq.f \
+dorml2.f \
+dlaexc.f \
+zlahqr.f \
+zdrot.f \
+dlabad.f \
+dlarft.f \
+zlassq.f \
+dlartg.f \
+zlarf.f \
+ztrexc.f \
+zgeev.f \
+dggbal.f \
+dtrtrs.f \
+zlatdf.f \
+dgeqr2.f \
+zlarfg.f \
+dgetrs.f \
+dlag2.f \
+dlaqge.f \
+dpotf2.f \
+zgetrf.f \
+ztgsy2.f \
+zgebal.f \
+dspgst.f \
+dormqr.f \
+drscl.f \
+dtrti2.f \
+dlaset.f \
+dgeesx.f \
+dpocon.f \
+dlasyf.f \
+dgerq2.f \
+dlasq3.f \
+dlansy.f \
+dgehrd.f \
+dgehd2.f \
+dsptrd.f \
+dorgtr.f \
+dormrq.f \
+dorm2r.f \
+dormr2.f \
+zgges.f \
+zunglq.f \
+zlanhe.f \
+zungl2.f \
+zhetrd.f \
+zhetd2.f \
+dlacon.f \
+dgesvx.f \
+zgetf2.f \
+ztgevc.f \
+dsteqr.f \
+dgelqf.f \
+zlarzb.f \
+zlarfx.f \
+dsysv.f \
+zlaqps.f \
+dtzrqf.f \
+dsytrf.f \
+xerbla.f \
+dtrsyl.f \
+dgelss.f \
+dtgsen.f \
+zgecon.f \
+dormbr.f \
+zlatrz.f \
+zungqr.f \
+dlabrd.f \
+dlasq4.f \
+dggev.f \
+dpptrf.f \
+zgelq2.f \
+dgeqpf.f \
+dormr3.f \
+dlanhs.f \
+dgerfs.f \
+dlarz.f \
+zgebrd.f \
+zgebd2.f \
+dgebak.f \
+dormrz.f \
+dbdsqr.f \
+dspev.f \
+dlaqp2.f \
+zung2r.f \
+dlange.f \
+zgeqrf.f \
+dormql.f \
+zgesvd.f \
+dladiv.f \
+dlas2.f \
+dgeequ.f \
+dsytf2.f \
+dlahqr.f \
+zlatrs.f \
+zheev.f \
+ztgex2.f \
+zlaic1.f \
+ztrsen.f \
+zlacgv.f \
+dgees.f \
+dlassq.f \
+zlascl.f \
+dtrexc.f \
+dlasq5.f \
+dormhr.f \
+zgesc2.f \
+dlatdf.f \
+dsycon.f \
+dlarfg.f \
+dorm2l.f \
+dsptrf.f \
+zungbr.f \
+dgesv.f \
+dgetrf.f \
+zhseqr.f \
+dtgsy2.f \
+dlaev2.f \
+dgebal.f \
+zlarfb.f \
+zlahrd.f \
+dlantr.f \
+zgghrd.f \
+dlatzm.f \
+ztgsyl.f \
+ztrtri.f \
+zlatrd.f \
+zlacpy.f \
+zgetri.f \
+dlasr.f \
+zgeqp3.f \
+zungql.f \
+dlanst.f \
+zlarzt.f \
+dorglq.f \
+dorgl2.f \
+dlasq6.f \
+dlasy2.f \
+dopgtr.f \
+dgeqlf.f \
+dgetf2.f \
+dtgevc.f \
+zunghr.f \
+dlarzb.f \
+dlarfx.f \
+zung2l.f \
+zggev.f \
+dzsum1.f \
+dlaqps.f \
+dtrcon.f \
+dlasrt.f \
+dsyev.f \
+dorgqr.f \
+dgecon.f \
+dlatrz.f \
+zlarz.f \
+ztgexc.f \
+zggbak.f \
+ztzrzf.f \
+dpotrs.f \
+dsytri.f \
+dgelq2.f \
+zpotrf.f \
+dgebrd.f \
+dgebd2.f \
+zgetc2.f \
+dorgrq.f \
+dorg2r.f \
+dorgr2.f \
+zhgeqz.f \
+dgeqrf.f \
+dlaln2.f \
+dgesvd.f \
+ztrevc.f \
+zgelsy.f \
+zgees.f \
+zlaswp.f \
+dspgv.f \
+dlanv2.f \
+zunmlq.f \
+dlae2.f \
+zunml2.f \
+dlatrs.f \
+dtgex2.f \
+dlaic1.f \
+dgels.f \
+dtrsen.f \
+zdrscl.f \
+zlarft.f \
+dlascl.f \
+zlartg.f \
+zggbal.f \
+dgesc2.f \
+dgerqf.f \
+zgeqr2.f \
+zgetrs.f \
+ilaenv.f \
+dorgbr.f \
+zpotf2.f \
+dhseqr.f \
+dlarf.f \
+dgegs.f \
+dgeev.f \
+dlarfb.f \
+zlasr.f \
+dlapy2.f \
+zunmqr.f \
+ztrti2.f \
+dlahrd.f \
+dgghrd.f \
+zlaset.f \
+dtgsyl.f \
+dtrtri.f \
+dlatrd.f \
+dlacpy.f \
+dgetri.f \
+zgehrd.f \
+zgehd2.f \
+dgeqp3.f \
+dorgql.f \
+zungtr.f \
+zunm2r.f \
+dlarzt.f \
+dlapmt.f \
+ieeeck.f \
+dlasq1.f \
+dorghr.f \
+zlacon.f \
+dgelsx.f \
+dsterf.f \
+zsteqr.f \
+zgelqf.f \
+dsytrs.f \
+dgges.f \
+dorg2l.f \
+dlapy3.f \
+lsame.f \
+ztrsyl.f \
+izmax1.f \
+ztgsen.f \
+zunmbr.f \
+zlabrd.f \
+dtgexc.f \
+dgeql2.f \
+dlagv2.f \
+dggbak.f \
+dtzrzf.f \
+zlaqr0.f \
+dlacn2.f \
+zlacn2.f \
+dlazq3.f \
+zlahr2.f \
+dlaqr0.f \
+iparmq.f \
+disnan.f \
+dlaisnan.f \
+dlahr2.f \
+zlaqr3.f \
+zlaqr4.f \
+zlaqr5.f \
+dlazq4.f \
+dlaqr3.f \
+dlaqr4.f \
+dlaqr5.f \
+zlaqr2.f \
+zlaqr1.f \
+dlaqr2.f \
+dlaqr1.f
+
+libscilapack_la_SOURCES = $(LAPACK_FORTRAN_SOURCES)
+
+libdummy_lapack_la_SOURCES = dlamch.f slamch.f
+
+libdummy_lapack_la_FFLAGS = `echo "@FFLAGS@"| sed -e 's|-O[0-9+]|-O0|'`
+
+
+libscilapack_la_LIBADD = libdummy-lapack.la \
+			$(top_builddir)/lib/blas/libsciblas.la
+
+libscilapack_la_PKGCONFIG = lapack.pc
+
+libdummy_lapack_la-dlamch.lo: dlamch.f
+	$(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-dlamch.lo `test -f 'dlamch.f' || echo '$(srcdir)/'`dlamch.f
+
+libdummy_lapack_la-slamch.lo: slamch.f
+	$(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-slamch.lo `test -f 'slamch.f' || echo '$(srcdir)/'`slamch.f
diff --git a/src/lib/lapack/Makefile.in b/src/lib/lapack/Makefile.in
new file mode 100644
index 00000000..6361011e
--- /dev/null
+++ b/src/lib/lapack/Makefile.in
@@ -0,0 +1,826 @@
+# Makefile.in generated by automake 1.10 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006  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/lapack
+DIST_COMMON = README $(srcdir)/Makefile.am $(srcdir)/Makefile.in
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+	$(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_HEADER = $(top_builddir)/includes/machine.h
+CONFIG_CLEAN_FILES =
+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 = $(noinst_LTLIBRARIES) $(pkglib_LTLIBRARIES)
+libdummy_lapack_la_LIBADD =
+am_libdummy_lapack_la_OBJECTS = libdummy_lapack_la-dlamch.lo \
+	libdummy_lapack_la-slamch.lo
+libdummy_lapack_la_OBJECTS = $(am_libdummy_lapack_la_OBJECTS)
+libdummy_lapack_la_LINK = $(LIBTOOL) --tag=F77 $(AM_LIBTOOLFLAGS) \
+	$(LIBTOOLFLAGS) --mode=link $(F77LD) \
+	$(libdummy_lapack_la_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) \
+	$(LDFLAGS) -o $@
+libscilapack_la_DEPENDENCIES = libdummy-lapack.la \
+	$(top_builddir)/lib/blas/libsciblas.la
+am__objects_1 = dlasv2.lo zgeqpf.lo zrot.lo dpotrf.lo zunmr3.lo \
+	zlanhs.lo zgebak.lo zbdsqr.lo zunmrz.lo dgetc2.lo zlaqp2.lo \
+	dsytrd.lo dsytd2.lo zlange.lo dlansp.lo dhgeqz.lo dlasq2.lo \
+	dtrevc.lo dgelsy.lo zladiv.lo dlaswp.lo dormlq.lo dorml2.lo \
+	dlaexc.lo zlahqr.lo zdrot.lo dlabad.lo dlarft.lo zlassq.lo \
+	dlartg.lo zlarf.lo ztrexc.lo zgeev.lo dggbal.lo dtrtrs.lo \
+	zlatdf.lo dgeqr2.lo zlarfg.lo dgetrs.lo dlag2.lo dlaqge.lo \
+	dpotf2.lo zgetrf.lo ztgsy2.lo zgebal.lo dspgst.lo dormqr.lo \
+	drscl.lo dtrti2.lo dlaset.lo dgeesx.lo dpocon.lo dlasyf.lo \
+	dgerq2.lo dlasq3.lo dlansy.lo dgehrd.lo dgehd2.lo dsptrd.lo \
+	dorgtr.lo dormrq.lo dorm2r.lo dormr2.lo zgges.lo zunglq.lo \
+	zlanhe.lo zungl2.lo zhetrd.lo zhetd2.lo dlacon.lo dgesvx.lo \
+	zgetf2.lo ztgevc.lo dsteqr.lo dgelqf.lo zlarzb.lo zlarfx.lo \
+	dsysv.lo zlaqps.lo dtzrqf.lo dsytrf.lo xerbla.lo dtrsyl.lo \
+	dgelss.lo dtgsen.lo zgecon.lo dormbr.lo zlatrz.lo zungqr.lo \
+	dlabrd.lo dlasq4.lo dggev.lo dpptrf.lo zgelq2.lo dgeqpf.lo \
+	dormr3.lo dlanhs.lo dgerfs.lo dlarz.lo zgebrd.lo zgebd2.lo \
+	dgebak.lo dormrz.lo dbdsqr.lo dspev.lo dlaqp2.lo zung2r.lo \
+	dlange.lo zgeqrf.lo dormql.lo zgesvd.lo dladiv.lo dlas2.lo \
+	dgeequ.lo dsytf2.lo dlahqr.lo zlatrs.lo zheev.lo ztgex2.lo \
+	zlaic1.lo ztrsen.lo zlacgv.lo dgees.lo dlassq.lo zlascl.lo \
+	dtrexc.lo dlasq5.lo dormhr.lo zgesc2.lo dlatdf.lo dsycon.lo \
+	dlarfg.lo dorm2l.lo dsptrf.lo zungbr.lo dgesv.lo dgetrf.lo \
+	zhseqr.lo dtgsy2.lo dlaev2.lo dgebal.lo zlarfb.lo zlahrd.lo \
+	dlantr.lo zgghrd.lo dlatzm.lo ztgsyl.lo ztrtri.lo zlatrd.lo \
+	zlacpy.lo zgetri.lo dlasr.lo zgeqp3.lo zungql.lo dlanst.lo \
+	zlarzt.lo dorglq.lo dorgl2.lo dlasq6.lo dlasy2.lo dopgtr.lo \
+	dgeqlf.lo dgetf2.lo dtgevc.lo zunghr.lo dlarzb.lo dlarfx.lo \
+	zung2l.lo zggev.lo dzsum1.lo dlaqps.lo dtrcon.lo dlasrt.lo \
+	dsyev.lo dorgqr.lo dgecon.lo dlatrz.lo zlarz.lo ztgexc.lo \
+	zggbak.lo ztzrzf.lo dpotrs.lo dsytri.lo dgelq2.lo zpotrf.lo \
+	dgebrd.lo dgebd2.lo zgetc2.lo dorgrq.lo dorg2r.lo dorgr2.lo \
+	zhgeqz.lo dgeqrf.lo dlaln2.lo dgesvd.lo ztrevc.lo zgelsy.lo \
+	zgees.lo zlaswp.lo dspgv.lo dlanv2.lo zunmlq.lo dlae2.lo \
+	zunml2.lo dlatrs.lo dtgex2.lo dlaic1.lo dgels.lo dtrsen.lo \
+	zdrscl.lo zlarft.lo dlascl.lo zlartg.lo zggbal.lo dgesc2.lo \
+	dgerqf.lo zgeqr2.lo zgetrs.lo ilaenv.lo dorgbr.lo zpotf2.lo \
+	dhseqr.lo dlarf.lo dgegs.lo dgeev.lo dlarfb.lo zlasr.lo \
+	dlapy2.lo zunmqr.lo ztrti2.lo dlahrd.lo dgghrd.lo zlaset.lo \
+	dtgsyl.lo dtrtri.lo dlatrd.lo dlacpy.lo dgetri.lo zgehrd.lo \
+	zgehd2.lo dgeqp3.lo dorgql.lo zungtr.lo zunm2r.lo dlarzt.lo \
+	dlapmt.lo ieeeck.lo dlasq1.lo dorghr.lo zlacon.lo dgelsx.lo \
+	dsterf.lo zsteqr.lo zgelqf.lo dsytrs.lo dgges.lo dorg2l.lo \
+	dlapy3.lo lsame.lo ztrsyl.lo izmax1.lo ztgsen.lo zunmbr.lo \
+	zlabrd.lo dtgexc.lo dgeql2.lo dlagv2.lo dggbak.lo dtzrzf.lo \
+	zlaqr0.lo dlacn2.lo zlacn2.lo dlazq3.lo zlahr2.lo dlaqr0.lo \
+	iparmq.lo disnan.lo dlaisnan.lo dlahr2.lo zlaqr3.lo zlaqr4.lo \
+	zlaqr5.lo dlazq4.lo dlaqr3.lo dlaqr4.lo dlaqr5.lo zlaqr2.lo \
+	zlaqr1.lo dlaqr2.lo dlaqr1.lo
+am_libscilapack_la_OBJECTS = $(am__objects_1)
+libscilapack_la_OBJECTS = $(am_libscilapack_la_OBJECTS)
+DEFAULT_INCLUDES = -I. -I$(top_builddir)/includes@am__isrc@
+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 $@
+SOURCES = $(libdummy_lapack_la_SOURCES) $(libscilapack_la_SOURCES)
+DIST_SOURCES = $(libdummy_lapack_la_SOURCES) \
+	$(libscilapack_la_SOURCES)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CXX = @CXX@
+CXXCPP = @CXXCPP@
+CXXDEPMODE = @CXXDEPMODE@
+CXXFLAGS = @CXXFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+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@
+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@
+
+#### Target ######
+modulename = lapack
+pkglib_LTLIBRARIES = libscilapack.la
+noinst_LTLIBRARIES = libdummy-lapack.la
+LAPACK_FORTRAN_SOURCES = dlasv2.f \
+zgeqpf.f \
+zrot.f \
+dpotrf.f \
+zunmr3.f \
+zlanhs.f \
+zgebak.f \
+zbdsqr.f \
+zunmrz.f \
+dgetc2.f \
+zlaqp2.f \
+dsytrd.f \
+dsytd2.f \
+zlange.f \
+dlansp.f \
+dhgeqz.f \
+dlasq2.f \
+dtrevc.f \
+dgelsy.f \
+zladiv.f \
+dlaswp.f \
+dormlq.f \
+dorml2.f \
+dlaexc.f \
+zlahqr.f \
+zdrot.f \
+dlabad.f \
+dlarft.f \
+zlassq.f \
+dlartg.f \
+zlarf.f \
+ztrexc.f \
+zgeev.f \
+dggbal.f \
+dtrtrs.f \
+zlatdf.f \
+dgeqr2.f \
+zlarfg.f \
+dgetrs.f \
+dlag2.f \
+dlaqge.f \
+dpotf2.f \
+zgetrf.f \
+ztgsy2.f \
+zgebal.f \
+dspgst.f \
+dormqr.f \
+drscl.f \
+dtrti2.f \
+dlaset.f \
+dgeesx.f \
+dpocon.f \
+dlasyf.f \
+dgerq2.f \
+dlasq3.f \
+dlansy.f \
+dgehrd.f \
+dgehd2.f \
+dsptrd.f \
+dorgtr.f \
+dormrq.f \
+dorm2r.f \
+dormr2.f \
+zgges.f \
+zunglq.f \
+zlanhe.f \
+zungl2.f \
+zhetrd.f \
+zhetd2.f \
+dlacon.f \
+dgesvx.f \
+zgetf2.f \
+ztgevc.f \
+dsteqr.f \
+dgelqf.f \
+zlarzb.f \
+zlarfx.f \
+dsysv.f \
+zlaqps.f \
+dtzrqf.f \
+dsytrf.f \
+xerbla.f \
+dtrsyl.f \
+dgelss.f \
+dtgsen.f \
+zgecon.f \
+dormbr.f \
+zlatrz.f \
+zungqr.f \
+dlabrd.f \
+dlasq4.f \
+dggev.f \
+dpptrf.f \
+zgelq2.f \
+dgeqpf.f \
+dormr3.f \
+dlanhs.f \
+dgerfs.f \
+dlarz.f \
+zgebrd.f \
+zgebd2.f \
+dgebak.f \
+dormrz.f \
+dbdsqr.f \
+dspev.f \
+dlaqp2.f \
+zung2r.f \
+dlange.f \
+zgeqrf.f \
+dormql.f \
+zgesvd.f \
+dladiv.f \
+dlas2.f \
+dgeequ.f \
+dsytf2.f \
+dlahqr.f \
+zlatrs.f \
+zheev.f \
+ztgex2.f \
+zlaic1.f \
+ztrsen.f \
+zlacgv.f \
+dgees.f \
+dlassq.f \
+zlascl.f \
+dtrexc.f \
+dlasq5.f \
+dormhr.f \
+zgesc2.f \
+dlatdf.f \
+dsycon.f \
+dlarfg.f \
+dorm2l.f \
+dsptrf.f \
+zungbr.f \
+dgesv.f \
+dgetrf.f \
+zhseqr.f \
+dtgsy2.f \
+dlaev2.f \
+dgebal.f \
+zlarfb.f \
+zlahrd.f \
+dlantr.f \
+zgghrd.f \
+dlatzm.f \
+ztgsyl.f \
+ztrtri.f \
+zlatrd.f \
+zlacpy.f \
+zgetri.f \
+dlasr.f \
+zgeqp3.f \
+zungql.f \
+dlanst.f \
+zlarzt.f \
+dorglq.f \
+dorgl2.f \
+dlasq6.f \
+dlasy2.f \
+dopgtr.f \
+dgeqlf.f \
+dgetf2.f \
+dtgevc.f \
+zunghr.f \
+dlarzb.f \
+dlarfx.f \
+zung2l.f \
+zggev.f \
+dzsum1.f \
+dlaqps.f \
+dtrcon.f \
+dlasrt.f \
+dsyev.f \
+dorgqr.f \
+dgecon.f \
+dlatrz.f \
+zlarz.f \
+ztgexc.f \
+zggbak.f \
+ztzrzf.f \
+dpotrs.f \
+dsytri.f \
+dgelq2.f \
+zpotrf.f \
+dgebrd.f \
+dgebd2.f \
+zgetc2.f \
+dorgrq.f \
+dorg2r.f \
+dorgr2.f \
+zhgeqz.f \
+dgeqrf.f \
+dlaln2.f \
+dgesvd.f \
+ztrevc.f \
+zgelsy.f \
+zgees.f \
+zlaswp.f \
+dspgv.f \
+dlanv2.f \
+zunmlq.f \
+dlae2.f \
+zunml2.f \
+dlatrs.f \
+dtgex2.f \
+dlaic1.f \
+dgels.f \
+dtrsen.f \
+zdrscl.f \
+zlarft.f \
+dlascl.f \
+zlartg.f \
+zggbal.f \
+dgesc2.f \
+dgerqf.f \
+zgeqr2.f \
+zgetrs.f \
+ilaenv.f \
+dorgbr.f \
+zpotf2.f \
+dhseqr.f \
+dlarf.f \
+dgegs.f \
+dgeev.f \
+dlarfb.f \
+zlasr.f \
+dlapy2.f \
+zunmqr.f \
+ztrti2.f \
+dlahrd.f \
+dgghrd.f \
+zlaset.f \
+dtgsyl.f \
+dtrtri.f \
+dlatrd.f \
+dlacpy.f \
+dgetri.f \
+zgehrd.f \
+zgehd2.f \
+dgeqp3.f \
+dorgql.f \
+zungtr.f \
+zunm2r.f \
+dlarzt.f \
+dlapmt.f \
+ieeeck.f \
+dlasq1.f \
+dorghr.f \
+zlacon.f \
+dgelsx.f \
+dsterf.f \
+zsteqr.f \
+zgelqf.f \
+dsytrs.f \
+dgges.f \
+dorg2l.f \
+dlapy3.f \
+lsame.f \
+ztrsyl.f \
+izmax1.f \
+ztgsen.f \
+zunmbr.f \
+zlabrd.f \
+dtgexc.f \
+dgeql2.f \
+dlagv2.f \
+dggbak.f \
+dtzrzf.f \
+zlaqr0.f \
+dlacn2.f \
+zlacn2.f \
+dlazq3.f \
+zlahr2.f \
+dlaqr0.f \
+iparmq.f \
+disnan.f \
+dlaisnan.f \
+dlahr2.f \
+zlaqr3.f \
+zlaqr4.f \
+zlaqr5.f \
+dlazq4.f \
+dlaqr3.f \
+dlaqr4.f \
+dlaqr5.f \
+zlaqr2.f \
+zlaqr1.f \
+dlaqr2.f \
+dlaqr1.f
+
+libscilapack_la_SOURCES = $(LAPACK_FORTRAN_SOURCES)
+libdummy_lapack_la_SOURCES = dlamch.f slamch.f
+libdummy_lapack_la_FFLAGS = `echo "@FFLAGS@"| sed -e 's|-O[0-9+]|-O0|'`
+libscilapack_la_LIBADD = libdummy-lapack.la \
+			$(top_builddir)/lib/blas/libsciblas.la
+
+libscilapack_la_PKGCONFIG = lapack.pc
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .f .lo .o .obj
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am  $(am__configure_deps)
+	@for dep in $?; do \
+	  case '$(am__configure_deps)' in \
+	    *$$dep*) \
+	      cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh \
+		&& exit 0; \
+	      exit 1;; \
+	  esac; \
+	done; \
+	echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign  lib/lapack/Makefile'; \
+	cd $(top_srcdir) && \
+	  $(AUTOMAKE) --foreign  lib/lapack/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+	@case '$?' in \
+	  *config.status*) \
+	    cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+	  *) \
+	    echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+	    cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+	esac;
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps)
+	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps)
+	cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+clean-noinstLTLIBRARIES:
+	-test -z "$(noinst_LTLIBRARIES)" || rm -f $(noinst_LTLIBRARIES)
+	@list='$(noinst_LTLIBRARIES)'; for p in $$list; do \
+	  dir="`echo $$p | sed -e 's|/[^/]*$$||'`"; \
+	  test "$$dir" != "$$p" || dir=.; \
+	  echo "rm -f \"$${dir}/so_locations\""; \
+	  rm -f "$${dir}/so_locations"; \
+	done
+install-pkglibLTLIBRARIES: $(pkglib_LTLIBRARIES)
+	@$(NORMAL_INSTALL)
+	test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)"
+	@list='$(pkglib_LTLIBRARIES)'; for p in $$list; do \
+	  if test -f $$p; then \
+	    f=$(am__strip_dir) \
+	    echo " $(LIBTOOL) --mode=install $(pkglibLTLIBRARIES_INSTALL) $(INSTALL_STRIP_FLAG) '$$p' '$(DESTDIR)$(pkglibdir)/$$f'"; \
+	    $(LIBTOOL) --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) --mode=uninstall rm -f '$(DESTDIR)$(pkglibdir)/$$p'"; \
+	  $(LIBTOOL) --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
+libdummy-lapack.la: $(libdummy_lapack_la_OBJECTS) $(libdummy_lapack_la_DEPENDENCIES) 
+	$(libdummy_lapack_la_LINK)  $(libdummy_lapack_la_OBJECTS) $(libdummy_lapack_la_LIBADD) $(LIBS)
+libscilapack.la: $(libscilapack_la_OBJECTS) $(libscilapack_la_DEPENDENCIES) 
+	$(F77LINK) -rpath $(pkglibdir) $(libscilapack_la_OBJECTS) $(libscilapack_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+	-rm -f *.$(OBJEXT)
+
+distclean-compile:
+	-rm -f *.tab.c
+
+.f.o:
+	$(F77COMPILE) -c -o $@ $<
+
+.f.obj:
+	$(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+.f.lo:
+	$(LTF77COMPILE) -c -o $@ $<
+
+mostlyclean-libtool:
+	-rm -f *.lo
+
+clean-libtool:
+	-rm -rf .libs _libs
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+	list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+	unique=`for i in $$list; do \
+	    if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+	  done | \
+	  $(AWK) '    { files[$$0] = 1; } \
+	       END { 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; } \
+	       END { 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=; \
+	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; } \
+	       END { 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-noinstLTLIBRARIES \
+	clean-pkglibLTLIBRARIES mostlyclean-am
+
+distclean: distclean-am
+	-rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+	distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+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-noinstLTLIBRARIES clean-pkglibLTLIBRARIES \
+	ctags distclean distclean-compile distclean-generic \
+	distclean-libtool distclean-tags distdir dvi dvi-am html \
+	html-am info info-am install install-am install-data \
+	install-data-am install-dvi install-dvi-am install-exec \
+	install-exec-am install-html install-html-am install-info \
+	install-info-am install-man install-pdf install-pdf-am \
+	install-pkglibLTLIBRARIES install-ps install-ps-am \
+	install-strip installcheck installcheck-am installdirs \
+	maintainer-clean maintainer-clean-generic mostlyclean \
+	mostlyclean-compile mostlyclean-generic mostlyclean-libtool \
+	pdf pdf-am ps ps-am tags uninstall uninstall-am \
+	uninstall-pkglibLTLIBRARIES
+
+
+libdummy_lapack_la-dlamch.lo: dlamch.f
+	$(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-dlamch.lo `test -f 'dlamch.f' || echo '$(srcdir)/'`dlamch.f
+
+libdummy_lapack_la-slamch.lo: slamch.f
+	$(LIBTOOL) --tag=F77 --mode=compile $(F77) $(libdummy_lapack_la_FFLAGS) -c -o libdummy_lapack_la-slamch.lo `test -f 'slamch.f' || echo '$(srcdir)/'`slamch.f
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/src/lib/lapack/README b/src/lib/lapack/README
new file mode 100644
index 00000000..c14fb64f
--- /dev/null
+++ b/src/lib/lapack/README
@@ -0,0 +1,5 @@
+This directory contains LAPACK routines.
+File xerbla.f is not used. 
+A customized version of xerbla
+for Scilab is in SCIDIR/system/xerbla.f
+
diff --git a/src/lib/lapack/dbdsqr.f b/src/lib/lapack/dbdsqr.f
new file mode 100644
index 00000000..b9f87ec1
--- /dev/null
+++ b/src/lib/lapack/dbdsqr.f
@@ -0,0 +1,742 @@
+      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+     $                   LDU, C, LDC, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DBDSQR computes the singular values and, optionally, the right and/or
+*  left singular vectors from the singular value decomposition (SVD) of
+*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
+*  zero-shift QR algorithm.  The SVD of B has the form
+* 
+*     B = Q * S * P**T
+* 
+*  where S is the diagonal matrix of singular values, Q is an orthogonal
+*  matrix of left singular vectors, and P is an orthogonal matrix of
+*  right singular vectors.  If left singular vectors are requested, this
+*  subroutine actually returns U*Q instead of Q, and, if right singular
+*  vectors are requested, this subroutine returns P**T*VT instead of
+*  P**T, for given real input matrices U and VT.  When U and VT are the
+*  orthogonal matrices that reduce a general matrix A to bidiagonal
+*  form:  A = U*B*VT, as computed by DGEBRD, then
+*
+*     A = (U*Q) * S * (P**T*VT)
+*
+*  is the SVD of A.  Optionally, the subroutine may also compute Q**T*C
+*  for a given real input matrix C.
+*
+*  See "Computing  Small Singular Values of Bidiagonal Matrices With
+*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
+*  no. 5, pp. 873-912, Sept 1990) and
+*  "Accurate singular values and differential qd algorithms," by
+*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
+*  Department, University of California at Berkeley, July 1992
+*  for a detailed description of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  B is upper bidiagonal;
+*          = 'L':  B is lower bidiagonal.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B.  N >= 0.
+*
+*  NCVT    (input) INTEGER
+*          The number of columns of the matrix VT. NCVT >= 0.
+*
+*  NRU     (input) INTEGER
+*          The number of rows of the matrix U. NRU >= 0.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C. NCC >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the bidiagonal matrix B.
+*          On exit, if INFO=0, the singular values of B in decreasing
+*          order.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the N-1 offdiagonal elements of the bidiagonal
+*          matrix B. 
+*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
+*          will contain the diagonal and superdiagonal elements of a
+*          bidiagonal matrix orthogonally equivalent to the one given
+*          as input.
+*
+*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
+*          On entry, an N-by-NCVT matrix VT.
+*          On exit, VT is overwritten by P**T * VT.
+*          Not referenced if NCVT = 0.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.
+*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
+*
+*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)
+*          On entry, an NRU-by-N matrix U.
+*          On exit, U is overwritten by U * Q.
+*          Not referenced if NRU = 0.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= max(1,NRU).
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
+*          On entry, an N-by-NCC matrix C.
+*          On exit, C is overwritten by Q**T * C.
+*          Not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*          if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  If INFO = -i, the i-th argument had an illegal value
+*          > 0:  the algorithm did not converge; D and E contain the
+*                elements of a bidiagonal matrix which is orthogonally
+*                similar to the input matrix B;  if INFO = i, i
+*                elements of E have not converged to zero.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
+*          TOLMUL controls the convergence criterion of the QR loop.
+*          If it is positive, TOLMUL*EPS is the desired relative
+*             precision in the computed singular values.
+*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
+*             desired absolute accuracy in the computed singular
+*             values (corresponds to relative accuracy
+*             abs(TOLMUL*EPS) in the largest singular value.
+*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
+*             between 10 (for fast convergence) and .1/EPS
+*             (for there to be some accuracy in the results).
+*          Default is to lose at either one eighth or 2 of the
+*             available decimal digits in each computed singular value
+*             (whichever is smaller).
+*
+*  MAXITR  INTEGER, default = 6
+*          MAXITR controls the maximum number of passes of the
+*          algorithm through its inner loop. The algorithms stops
+*          (and so fails to converge) if the number of passes
+*          through the inner loop exceeds MAXITR*N**2.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   NEGONE
+      PARAMETER          ( NEGONE = -1.0D0 )
+      DOUBLE PRECISION   HNDRTH
+      PARAMETER          ( HNDRTH = 0.01D0 )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 10.0D0 )
+      DOUBLE PRECISION   HNDRD
+      PARAMETER          ( HNDRD = 100.0D0 )
+      DOUBLE PRECISION   MEIGTH
+      PARAMETER          ( MEIGTH = -0.125D0 )
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 6 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, ROTATE
+      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
+     $                   NM12, NM13, OLDLL, OLDM
+      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
+     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
+     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
+     $                   SN, THRESH, TOL, TOLMUL, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
+     $                   DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LOWER = LSAME( UPLO, 'L' )
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NCVT.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+         INFO = -9
+      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+         INFO = -11
+      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DBDSQR', -INFO )
+         RETURN
+      END IF
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 )
+     $   GO TO 160
+*
+*     ROTATE is true if any singular vectors desired, false otherwise
+*
+      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+*
+*     If no singular vectors desired, use qd algorithm
+*
+      IF( .NOT.ROTATE ) THEN
+         CALL DLASQ1( N, D, E, WORK, INFO )
+         RETURN
+      END IF
+*
+      NM1 = N - 1
+      NM12 = NM1 + NM1
+      NM13 = NM12 + NM1
+      IDIR = 0
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'Epsilon' )
+      UNFL = DLAMCH( 'Safe minimum' )
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left
+*
+      IF( LOWER ) THEN
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            WORK( I ) = CS
+            WORK( NM1+I ) = SN
+   10    CONTINUE
+*
+*        Update singular vectors if desired
+*
+         IF( NRU.GT.0 )
+     $      CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
+     $                  LDU )
+         IF( NCC.GT.0 )
+     $      CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
+     $                  LDC )
+      END IF
+*
+*     Compute singular values to relative accuracy TOL
+*     (By setting TOL to be negative, algorithm will compute
+*     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
+*
+      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
+      TOL = TOLMUL*EPS
+*
+*     Compute approximate maximum, minimum singular values
+*
+      SMAX = ZERO
+      DO 20 I = 1, N
+         SMAX = MAX( SMAX, ABS( D( I ) ) )
+   20 CONTINUE
+      DO 30 I = 1, N - 1
+         SMAX = MAX( SMAX, ABS( E( I ) ) )
+   30 CONTINUE
+      SMINL = ZERO
+      IF( TOL.GE.ZERO ) THEN
+*
+*        Relative accuracy desired
+*
+         SMINOA = ABS( D( 1 ) )
+         IF( SMINOA.EQ.ZERO )
+     $      GO TO 50
+         MU = SMINOA
+         DO 40 I = 2, N
+            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+            SMINOA = MIN( SMINOA, MU )
+            IF( SMINOA.EQ.ZERO )
+     $         GO TO 50
+   40    CONTINUE
+   50    CONTINUE
+         SMINOA = SMINOA / SQRT( DBLE( N ) )
+         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
+      ELSE
+*
+*        Absolute accuracy desired
+*
+         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
+      END IF
+*
+*     Prepare for main iteration loop for the singular values
+*     (MAXIT is the maximum number of passes through the inner
+*     loop permitted before nonconvergence signalled.)
+*
+      MAXIT = MAXITR*N*N
+      ITER = 0
+      OLDLL = -1
+      OLDM = -1
+*
+*     M points to last element of unconverged part of matrix
+*
+      M = N
+*
+*     Begin main iteration loop
+*
+   60 CONTINUE
+*
+*     Check for convergence or exceeding iteration count
+*
+      IF( M.LE.1 )
+     $   GO TO 160
+      IF( ITER.GT.MAXIT )
+     $   GO TO 200
+*
+*     Find diagonal block of matrix to work on
+*
+      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
+     $   D( M ) = ZERO
+      SMAX = ABS( D( M ) )
+      SMIN = SMAX
+      DO 70 LLL = 1, M - 1
+         LL = M - LLL
+         ABSS = ABS( D( LL ) )
+         ABSE = ABS( E( LL ) )
+         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
+     $      D( LL ) = ZERO
+         IF( ABSE.LE.THRESH )
+     $      GO TO 80
+         SMIN = MIN( SMIN, ABSS )
+         SMAX = MAX( SMAX, ABSS, ABSE )
+   70 CONTINUE
+      LL = 0
+      GO TO 90
+   80 CONTINUE
+      E( LL ) = ZERO
+*
+*     Matrix splits since E(LL) = 0
+*
+      IF( LL.EQ.M-1 ) THEN
+*
+*        Convergence of bottom singular value, return to top of loop
+*
+         M = M - 1
+         GO TO 60
+      END IF
+   90 CONTINUE
+      LL = LL + 1
+*
+*     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
+*
+      IF( LL.EQ.M-1 ) THEN
+*
+*        2 by 2 block, handle separately
+*
+         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
+     $                COSR, SINL, COSL )
+         D( M-1 ) = SIGMX
+         E( M-1 ) = ZERO
+         D( M ) = SIGMN
+*
+*        Compute singular vectors, if desired
+*
+         IF( NCVT.GT.0 )
+     $      CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
+     $                 SINR )
+         IF( NRU.GT.0 )
+     $      CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+         IF( NCC.GT.0 )
+     $      CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
+     $                 SINL )
+         M = M - 2
+         GO TO 60
+      END IF
+*
+*     If working on new submatrix, choose shift direction
+*     (from larger end diagonal element towards smaller)
+*
+      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
+         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
+*
+*           Chase bulge from top (big end) to bottom (small end)
+*
+            IDIR = 1
+         ELSE
+*
+*           Chase bulge from bottom (big end) to top (small end)
+*
+            IDIR = 2
+         END IF
+      END IF
+*
+*     Apply convergence tests
+*
+      IF( IDIR.EQ.1 ) THEN
+*
+*        Run convergence test in forward direction
+*        First apply standard test to bottom of matrix
+*
+         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
+     $       ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
+            E( M-1 ) = ZERO
+            GO TO 60
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion forward
+*
+            MU = ABS( D( LL ) )
+            SMINL = MU
+            DO 100 LLL = LL, M - 1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 60
+               END IF
+               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  100       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Run convergence test in backward direction
+*        First apply standard test to top of matrix
+*
+         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
+     $       ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
+            E( LL ) = ZERO
+            GO TO 60
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion backward
+*
+            MU = ABS( D( M ) )
+            SMINL = MU
+            DO 110 LLL = M - 1, LL, -1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 60
+               END IF
+               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  110       CONTINUE
+         END IF
+      END IF
+      OLDLL = LL
+      OLDM = M
+*
+*     Compute shift.  First, test if shifting would ruin relative
+*     accuracy, and if so set the shift to zero.
+*
+      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
+     $    MAX( EPS, HNDRTH*TOL ) ) THEN
+*
+*        Use a zero shift to avoid loss of relative accuracy
+*
+         SHIFT = ZERO
+      ELSE
+*
+*        Compute the shift from 2-by-2 block at end of matrix
+*
+         IF( IDIR.EQ.1 ) THEN
+            SLL = ABS( D( LL ) )
+            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+         ELSE
+            SLL = ABS( D( M ) )
+            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
+         END IF
+*
+*        Test if shift negligible, and if so set to zero
+*
+         IF( SLL.GT.ZERO ) THEN
+            IF( ( SHIFT / SLL )**2.LT.EPS )
+     $         SHIFT = ZERO
+         END IF
+      END IF
+*
+*     Increment iteration count
+*
+      ITER = ITER + M - LL
+*
+*     If SHIFT = 0, do simplified QR iteration
+*
+      IF( SHIFT.EQ.ZERO ) THEN
+         IF( IDIR.EQ.1 ) THEN
+*
+*           Chase bulge from top to bottom
+*           Save cosines and sines for later singular vector updates
+*
+            CS = ONE
+            OLDCS = ONE
+            DO 120 I = LL, M - 1
+               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+               WORK( I-LL+1 ) = CS
+               WORK( I-LL+1+NM1 ) = SN
+               WORK( I-LL+1+NM12 ) = OLDCS
+               WORK( I-LL+1+NM13 ) = OLDSN
+  120       CONTINUE
+            H = D( M )*CS
+            D( M ) = H*OLDCS
+            E( M-1 ) = H*OLDSN
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+     $                     WORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( M-1 ) ).LE.THRESH )
+     $         E( M-1 ) = ZERO
+*
+         ELSE
+*
+*           Chase bulge from bottom to top
+*           Save cosines and sines for later singular vector updates
+*
+            CS = ONE
+            OLDCS = ONE
+            DO 130 I = M, LL + 1, -1
+               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               IF( I.LT.M )
+     $            E( I ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+               WORK( I-LL ) = CS
+               WORK( I-LL+NM1 ) = -SN
+               WORK( I-LL+NM12 ) = OLDCS
+               WORK( I-LL+NM13 ) = -OLDSN
+  130       CONTINUE
+            H = D( LL )*CS
+            D( LL ) = H*OLDCS
+            E( LL ) = H*OLDSN
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+     $                     WORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+     $                     WORK( N ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( LL ) ).LE.THRESH )
+     $         E( LL ) = ZERO
+         END IF
+      ELSE
+*
+*        Use nonzero shift
+*
+         IF( IDIR.EQ.1 ) THEN
+*
+*           Chase bulge from top to bottom
+*           Save cosines and sines for later singular vector updates
+*
+            F = ( ABS( D( LL ) )-SHIFT )*
+     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
+            G = E( LL )
+            DO 140 I = LL, M - 1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = R
+               F = COSR*D( I ) + SINR*E( I )
+               E( I ) = COSR*E( I ) - SINR*D( I )
+               G = SINR*D( I+1 )
+               D( I+1 ) = COSR*D( I+1 )
+               CALL DLARTG( F, G, COSL, SINL, R )
+               D( I ) = R
+               F = COSL*E( I ) + SINL*D( I+1 )
+               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
+               IF( I.LT.M-1 ) THEN
+                  G = SINL*E( I+1 )
+                  E( I+1 ) = COSL*E( I+1 )
+               END IF
+               WORK( I-LL+1 ) = COSR
+               WORK( I-LL+1+NM1 ) = SINR
+               WORK( I-LL+1+NM12 ) = COSL
+               WORK( I-LL+1+NM13 ) = SINL
+  140       CONTINUE
+            E( M-1 ) = F
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+     $                     WORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( M-1 ) ).LE.THRESH )
+     $         E( M-1 ) = ZERO
+*
+         ELSE
+*
+*           Chase bulge from bottom to top
+*           Save cosines and sines for later singular vector updates
+*
+            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
+     $          D( M ) )
+            G = E( M-1 )
+            DO 150 I = M, LL + 1, -1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               IF( I.LT.M )
+     $            E( I ) = R
+               F = COSR*D( I ) + SINR*E( I-1 )
+               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
+               G = SINR*D( I-1 )
+               D( I-1 ) = COSR*D( I-1 )
+               CALL DLARTG( F, G, COSL, SINL, R )
+               D( I ) = R
+               F = COSL*E( I-1 ) + SINL*D( I-1 )
+               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
+               IF( I.GT.LL+1 ) THEN
+                  G = SINL*E( I-2 )
+                  E( I-2 ) = COSL*E( I-2 )
+               END IF
+               WORK( I-LL ) = COSR
+               WORK( I-LL+NM1 ) = -SINR
+               WORK( I-LL+NM12 ) = COSL
+               WORK( I-LL+NM13 ) = -SINL
+  150       CONTINUE
+            E( LL ) = F
+*
+*           Test convergence
+*
+            IF( ABS( E( LL ) ).LE.THRESH )
+     $         E( LL ) = ZERO
+*
+*           Update singular vectors if desired
+*
+            IF( NCVT.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+     $                     WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+     $                     WORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+     $                     WORK( N ), C( LL, 1 ), LDC )
+         END IF
+      END IF
+*
+*     QR iteration finished, go back and check convergence
+*
+      GO TO 60
+*
+*     All singular values converged, so make them positive
+*
+  160 CONTINUE
+      DO 170 I = 1, N
+         IF( D( I ).LT.ZERO ) THEN
+            D( I ) = -D( I )
+*
+*           Change sign of singular vectors, if desired
+*
+            IF( NCVT.GT.0 )
+     $         CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
+         END IF
+  170 CONTINUE
+*
+*     Sort the singular values into decreasing order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 190 I = 1, N - 1
+*
+*        Scan for smallest D(I)
+*
+         ISUB = 1
+         SMIN = D( 1 )
+         DO 180 J = 2, N + 1 - I
+            IF( D( J ).LE.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+  180    CONTINUE
+         IF( ISUB.NE.N+1-I ) THEN
+*
+*           Swap singular values and vectors
+*
+            D( ISUB ) = D( N+1-I )
+            D( N+1-I ) = SMIN
+            IF( NCVT.GT.0 )
+     $         CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+     $                     LDVT )
+            IF( NRU.GT.0 )
+     $         CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
+         END IF
+  190 CONTINUE
+      GO TO 220
+*
+*     Maximum number of iterations exceeded, failure to converge
+*
+  200 CONTINUE
+      INFO = 0
+      DO 210 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  210 CONTINUE
+  220 CONTINUE
+      RETURN
+*
+*     End of DBDSQR
+*
+      END
diff --git a/src/lib/lapack/dgebak.f b/src/lib/lapack/dgebak.f
new file mode 100644
index 00000000..b8e9be56
--- /dev/null
+++ b/src/lib/lapack/dgebak.f
@@ -0,0 +1,188 @@
+      SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB, SIDE
+      INTEGER            IHI, ILO, INFO, LDV, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   SCALE( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEBAK forms the right or left eigenvectors of a real general matrix
+*  by backward transformation on the computed eigenvectors of the
+*  balanced matrix output by DGEBAL.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the type of backward transformation required:
+*          = 'N', do nothing, return immediately;
+*          = 'P', do backward transformation for permutation only;
+*          = 'S', do backward transformation for scaling only;
+*          = 'B', do backward transformations for both permutation and
+*                 scaling.
+*          JOB must be the same as the argument JOB supplied to DGEBAL.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  V contains right eigenvectors;
+*          = 'L':  V contains left eigenvectors.
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrix V.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          The integers ILO and IHI determined by DGEBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  SCALE   (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutation and scaling factors, as returned
+*          by DGEBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by DHSEIN or DTREVC.
+*          On exit, V is overwritten by the transformed eigenvectors.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, II, K
+      DOUBLE PRECISION   S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test the input parameters
+*
+      RIGHTV = LSAME( SIDE, 'R' )
+      LEFTV = LSAME( SIDE, 'L' )
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -7
+      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEBAK', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( LSAME( JOB, 'N' ) )
+     $   RETURN
+*
+      IF( ILO.EQ.IHI )
+     $   GO TO 30
+*
+*     Backward balance
+*
+      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+         IF( RIGHTV ) THEN
+            DO 10 I = ILO, IHI
+               S = SCALE( I )
+               CALL DSCAL( M, S, V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               S = ONE / SCALE( I )
+               CALL DSCAL( M, S, V( I, 1 ), LDV )
+   20       CONTINUE
+         END IF
+*
+      END IF
+*
+*     Backward permutation
+*
+*     For  I = ILO-1 step -1 until 1,
+*              IHI+1 step 1 until N do --
+*
+   30 CONTINUE
+      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+         IF( RIGHTV ) THEN
+            DO 40 II = 1, N
+               I = II
+               IF( I.GE.ILO .AND. I.LE.IHI )
+     $            GO TO 40
+               IF( I.LT.ILO )
+     $            I = ILO - II
+               K = SCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 40
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   40       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 50 II = 1, N
+               I = II
+               IF( I.GE.ILO .AND. I.LE.IHI )
+     $            GO TO 50
+               IF( I.LT.ILO )
+     $            I = ILO - II
+               K = SCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 50
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   50       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEBAK
+*
+      END
diff --git a/src/lib/lapack/dgebal.f b/src/lib/lapack/dgebal.f
new file mode 100644
index 00000000..1796577b
--- /dev/null
+++ b/src/lib/lapack/dgebal.f
@@ -0,0 +1,322 @@
+      SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            IHI, ILO, INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), SCALE( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEBAL balances a general real matrix A.  This involves, first,
+*  permuting A by a similarity transformation to isolate eigenvalues
+*  in the first 1 to ILO-1 and last IHI+1 to N elements on the
+*  diagonal; and second, applying a diagonal similarity transformation
+*  to rows and columns ILO to IHI to make the rows and columns as
+*  close in norm as possible.  Both steps are optional.
+*
+*  Balancing may reduce the 1-norm of the matrix, and improve the
+*  accuracy of the computed eigenvalues and/or eigenvectors.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the operations to be performed on A:
+*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+*                  for i = 1,...,N;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the input matrix A.
+*          On exit,  A is overwritten by the balanced matrix.
+*          If JOB = 'N', A is not referenced.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are set to integers such that on exit
+*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  SCALE   (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied to
+*          A.  If P(j) is the index of the row and column interchanged
+*          with row and column j and D(j) is the scaling factor
+*          applied to row and column j, then
+*          SCALE(j) = P(j)    for j = 1,...,ILO-1
+*                   = D(j)    for j = ILO,...,IHI
+*                   = P(j)    for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The permutations consist of row and column interchanges which put
+*  the matrix in the form
+*
+*             ( T1   X   Y  )
+*     P A P = (  0   B   Z  )
+*             (  0   0   T2 )
+*
+*  where T1 and T2 are upper triangular matrices whose eigenvalues lie
+*  along the diagonal.  The column indices ILO and IHI mark the starting
+*  and ending columns of the submatrix B. Balancing consists of applying
+*  a diagonal similarity transformation inv(D) * B * D to make the
+*  1-norms of each row of B and its corresponding column nearly equal.
+*  The output matrix is
+*
+*     ( T1     X*D          Y    )
+*     (  0  inv(D)*B*D  inv(D)*Z ).
+*     (  0      0           T2   )
+*
+*  Information about the permutations P and the diagonal matrix D is
+*  returned in the vector SCALE.
+*
+*  This subroutine is based on the EISPACK routine BALANC.
+*
+*  Modified by Tzu-Yi Chen, Computer Science Division, University of
+*    California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   SCLFAC
+      PARAMETER          ( SCLFAC = 2.0D+0 )
+      DOUBLE PRECISION   FACTOR
+      PARAMETER          ( FACTOR = 0.95D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOCONV
+      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
+      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+     $                   SFMIN2
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEBAL', -INFO )
+         RETURN
+      END IF
+*
+      K = 1
+      L = N
+*
+      IF( N.EQ.0 )
+     $   GO TO 210
+*
+      IF( LSAME( JOB, 'N' ) ) THEN
+         DO 10 I = 1, N
+            SCALE( I ) = ONE
+   10    CONTINUE
+         GO TO 210
+      END IF
+*
+      IF( LSAME( JOB, 'S' ) )
+     $   GO TO 120
+*
+*     Permutation to isolate eigenvalues if possible
+*
+      GO TO 50
+*
+*     Row and column exchange.
+*
+   20 CONTINUE
+      SCALE( M ) = J
+      IF( J.EQ.M )
+     $   GO TO 30
+*
+      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
+*
+   30 CONTINUE
+      GO TO ( 40, 80 )IEXC
+*
+*     Search for rows isolating an eigenvalue and push them down.
+*
+   40 CONTINUE
+      IF( L.EQ.1 )
+     $   GO TO 210
+      L = L - 1
+*
+   50 CONTINUE
+      DO 70 J = L, 1, -1
+*
+         DO 60 I = 1, L
+            IF( I.EQ.J )
+     $         GO TO 60
+            IF( A( J, I ).NE.ZERO )
+     $         GO TO 70
+   60    CONTINUE
+*
+         M = L
+         IEXC = 1
+         GO TO 20
+   70 CONTINUE
+*
+      GO TO 90
+*
+*     Search for columns isolating an eigenvalue and push them left.
+*
+   80 CONTINUE
+      K = K + 1
+*
+   90 CONTINUE
+      DO 110 J = K, L
+*
+         DO 100 I = K, L
+            IF( I.EQ.J )
+     $         GO TO 100
+            IF( A( I, J ).NE.ZERO )
+     $         GO TO 110
+  100    CONTINUE
+*
+         M = K
+         IEXC = 2
+         GO TO 20
+  110 CONTINUE
+*
+  120 CONTINUE
+      DO 130 I = K, L
+         SCALE( I ) = ONE
+  130 CONTINUE
+*
+      IF( LSAME( JOB, 'P' ) )
+     $   GO TO 210
+*
+*     Balance the submatrix in rows K to L.
+*
+*     Iterative loop for norm reduction
+*
+      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      SFMAX1 = ONE / SFMIN1
+      SFMIN2 = SFMIN1*SCLFAC
+      SFMAX2 = ONE / SFMIN2
+  140 CONTINUE
+      NOCONV = .FALSE.
+*
+      DO 200 I = K, L
+         C = ZERO
+         R = ZERO
+*
+         DO 150 J = K, L
+            IF( J.EQ.I )
+     $         GO TO 150
+            C = C + ABS( A( J, I ) )
+            R = R + ABS( A( I, J ) )
+  150    CONTINUE
+         ICA = IDAMAX( L, A( 1, I ), 1 )
+         CA = ABS( A( ICA, I ) )
+         IRA = IDAMAX( N-K+1, A( I, K ), LDA )
+         RA = ABS( A( I, IRA+K-1 ) )
+*
+*        Guard against zero C or R due to underflow.
+*
+         IF( C.EQ.ZERO .OR. R.EQ.ZERO )
+     $      GO TO 200
+         G = R / SCLFAC
+         F = ONE
+         S = C + R
+  160    CONTINUE
+         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
+     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
+         F = F*SCLFAC
+         C = C*SCLFAC
+         CA = CA*SCLFAC
+         R = R / SCLFAC
+         G = G / SCLFAC
+         RA = RA / SCLFAC
+         GO TO 160
+*
+  170    CONTINUE
+         G = C / SCLFAC
+  180    CONTINUE
+         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
+     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
+         F = F / SCLFAC
+         C = C / SCLFAC
+         G = G / SCLFAC
+         CA = CA / SCLFAC
+         R = R*SCLFAC
+         RA = RA*SCLFAC
+         GO TO 180
+*
+*        Now balance.
+*
+  190    CONTINUE
+         IF( ( C+R ).GE.FACTOR*S )
+     $      GO TO 200
+         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
+            IF( F*SCALE( I ).LE.SFMIN1 )
+     $         GO TO 200
+         END IF
+         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
+            IF( SCALE( I ).GE.SFMAX1 / F )
+     $         GO TO 200
+         END IF
+         G = ONE / F
+         SCALE( I ) = SCALE( I )*F
+         NOCONV = .TRUE.
+*
+         CALL DSCAL( N-K+1, G, A( I, K ), LDA )
+         CALL DSCAL( L, F, A( 1, I ), 1 )
+*
+  200 CONTINUE
+*
+      IF( NOCONV )
+     $   GO TO 140
+*
+  210 CONTINUE
+      ILO = K
+      IHI = L
+*
+      RETURN
+*
+*     End of DGEBAL
+*
+      END
diff --git a/src/lib/lapack/dgebd2.f b/src/lib/lapack/dgebd2.f
new file mode 100644
index 00000000..b9eb6387
--- /dev/null
+++ b/src/lib/lapack/dgebd2.f
@@ -0,0 +1,239 @@
+      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEBD2 reduces a real general m by n matrix A to upper or lower
+*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n general matrix to be reduced.
+*          On exit,
+*          if m >= n, the diagonal and the first superdiagonal are
+*            overwritten with the upper bidiagonal matrix B; the
+*            elements below the diagonal, with the array TAUQ, represent
+*            the orthogonal matrix Q as a product of elementary
+*            reflectors, and the elements above the first superdiagonal,
+*            with the array TAUP, represent the orthogonal matrix P as
+*            a product of elementary reflectors;
+*          if m < n, the diagonal and the first subdiagonal are
+*            overwritten with the lower bidiagonal matrix B; the
+*            elements below the first subdiagonal, with the array TAUQ,
+*            represent the orthogonal matrix Q as a product of
+*            elementary reflectors, and the elements above the diagonal,
+*            with the array TAUP, represent the orthogonal matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The off-diagonal elements of the bidiagonal matrix B:
+*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit.
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*  If m >= n,
+*
+*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are real scalars, and v and u are real vectors;
+*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+*  tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n,
+*
+*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are real scalars, and v and u are real vectors;
+*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+*  tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The contents of A on exit are illustrated by the following examples:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
+*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
+*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
+*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
+*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
+*    (  v1  v2  v3  v4  v5 )
+*
+*  where d and e denote diagonal and off-diagonal elements of B, vi
+*  denotes an element of the vector defining H(i), and ui an element of
+*  the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'DGEBD2', -INFO )
+         RETURN
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        Reduce to upper bidiagonal form
+*
+         DO 10 I = 1, N
+*
+*           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+            CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                   TAUQ( I ) )
+            D( I ) = A( I, I )
+            A( I, I ) = ONE
+*
+*           Apply H(i) to A(i:m,i+1:n) from the left
+*
+            IF( I.LT.N )
+     $         CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
+     $                     A( I, I+1 ), LDA, WORK )
+            A( I, I ) = D( I )
+*
+            IF( I.LT.N ) THEN
+*
+*              Generate elementary reflector G(i) to annihilate
+*              A(i,i+2:n)
+*
+               CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+     $                      LDA, TAUP( I ) )
+               E( I ) = A( I, I+1 )
+               A( I, I+1 ) = ONE
+*
+*              Apply G(i) to A(i+1:m,i+1:n) from the right
+*
+               CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+               A( I, I+1 ) = E( I )
+            ELSE
+               TAUP( I ) = ZERO
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Reduce to lower bidiagonal form
+*
+         DO 20 I = 1, M
+*
+*           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
+*
+            CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+     $                   TAUP( I ) )
+            D( I ) = A( I, I )
+            A( I, I ) = ONE
+*
+*           Apply G(i) to A(i+1:m,i:n) from the right
+*
+            IF( I.LT.M )
+     $         CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
+            A( I, I ) = D( I )
+*
+            IF( I.LT.M ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(i+2:m,i)
+*
+               CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+     $                      TAUQ( I ) )
+               E( I ) = A( I+1, I )
+               A( I+1, I ) = ONE
+*
+*              Apply H(i) to A(i+1:m,i+1:n) from the left
+*
+               CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
+     $                     A( I+1, I+1 ), LDA, WORK )
+               A( I+1, I ) = E( I )
+            ELSE
+               TAUQ( I ) = ZERO
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DGEBD2
+*
+      END
diff --git a/src/lib/lapack/dgebrd.f b/src/lib/lapack/dgebrd.f
new file mode 100644
index 00000000..6544715d
--- /dev/null
+++ b/src/lib/lapack/dgebrd.f
@@ -0,0 +1,268 @@
+      SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEBRD reduces a general real M-by-N matrix A to upper or lower
+*  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
+*
+*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N general matrix to be reduced.
+*          On exit,
+*          if m >= n, the diagonal and the first superdiagonal are
+*            overwritten with the upper bidiagonal matrix B; the
+*            elements below the diagonal, with the array TAUQ, represent
+*            the orthogonal matrix Q as a product of elementary
+*            reflectors, and the elements above the first superdiagonal,
+*            with the array TAUP, represent the orthogonal matrix P as
+*            a product of elementary reflectors;
+*          if m < n, the diagonal and the first subdiagonal are
+*            overwritten with the lower bidiagonal matrix B; the
+*            elements below the first subdiagonal, with the array TAUQ,
+*            represent the orthogonal matrix Q as a product of
+*            elementary reflectors, and the elements above the diagonal,
+*            with the array TAUP, represent the orthogonal matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The off-diagonal elements of the bidiagonal matrix B:
+*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,M,N).
+*          For optimum performance LWORK >= (M+N)*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*  If m >= n,
+*
+*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are real scalars, and v and u are real vectors;
+*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+*  tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n,
+*
+*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are real scalars, and v and u are real vectors;
+*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+*  tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The contents of A on exit are illustrated by the following examples:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
+*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
+*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
+*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
+*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
+*    (  v1  v2  v3  v4  v5 )
+*
+*  where d and e denote diagonal and off-diagonal elements of B, vi
+*  denotes an element of the vector defining H(i), and ui an element of
+*  the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+     $                   NBMIN, NX
+      DOUBLE PRECISION   WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEBD2, DGEMM, DLABRD, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
+      LWKOPT = ( M+N )*NB
+      WORK( 1 ) = DBLE( LWKOPT )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'DGEBRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      MINMN = MIN( M, N )
+      IF( MINMN.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      WS = MAX( M, N )
+      LDWRKX = M
+      LDWRKY = N
+*
+      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+*        Set the crossover point NX.
+*
+         NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
+*
+*        Determine when to switch from blocked to unblocked code.
+*
+         IF( NX.LT.MINMN ) THEN
+            WS = ( M+N )*NB
+            IF( LWORK.LT.WS ) THEN
+*
+*              Not enough work space for the optimal NB, consider using
+*              a smaller block size.
+*
+               NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 )
+               IF( LWORK.GE.( M+N )*NBMIN ) THEN
+                  NB = LWORK / ( M+N )
+               ELSE
+                  NB = 1
+                  NX = MINMN
+               END IF
+            END IF
+         END IF
+      ELSE
+         NX = MINMN
+      END IF
+*
+      DO 30 I = 1, MINMN - NX, NB
+*
+*        Reduce rows and columns i:i+nb-1 to bidiagonal form and return
+*        the matrices X and Y which are needed to update the unreduced
+*        part of the matrix
+*
+         CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
+     $                TAUQ( I ), TAUP( I ), WORK, LDWRKX,
+     $                WORK( LDWRKX*NB+1 ), LDWRKY )
+*
+*        Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
+*        of the form  A := A - V*Y' - X*U'
+*
+         CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
+     $               NB, -ONE, A( I+NB, I ), LDA,
+     $               WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
+     $               A( I+NB, I+NB ), LDA )
+         CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
+     $               NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
+     $               ONE, A( I+NB, I+NB ), LDA )
+*
+*        Copy diagonal and off-diagonal elements of B back into A
+*
+         IF( M.GE.N ) THEN
+            DO 10 J = I, I + NB - 1
+               A( J, J ) = D( J )
+               A( J, J+1 ) = E( J )
+   10       CONTINUE
+         ELSE
+            DO 20 J = I, I + NB - 1
+               A( J, J ) = D( J )
+               A( J+1, J ) = E( J )
+   20       CONTINUE
+         END IF
+   30 CONTINUE
+*
+*     Use unblocked code to reduce the remainder of the matrix
+*
+      CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $             TAUQ( I ), TAUP( I ), WORK, IINFO )
+      WORK( 1 ) = WS
+      RETURN
+*
+*     End of DGEBRD
+*
+      END
diff --git a/src/lib/lapack/dgecon.f b/src/lib/lapack/dgecon.f
new file mode 100644
index 00000000..807cafca
--- /dev/null
+++ b/src/lib/lapack/dgecon.f
@@ -0,0 +1,185 @@
+      SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGECON estimates the reciprocal of the condition number of a general
+*  real matrix A, in either the 1-norm or the infinity-norm, using
+*  the LU factorization computed by DGETRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies whether the 1-norm condition number or the
+*          infinity-norm condition number is required:
+*          = '1' or 'O':  1-norm;
+*          = 'I':         Infinity-norm.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by DGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          If NORM = '1' or 'O', the 1-norm of the original matrix A.
+*          If NORM = 'I', the infinity-norm of the original matrix A.
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      DOUBLE PRECISION   AINVNM, SCALE, SL, SMLNUM, SU
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLATRS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGECON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   10 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+     $                   LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+*
+*           Multiply by inv(U).
+*
+            CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+     $                   LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+*
+*           Multiply by inv(L').
+*
+            CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
+     $                   LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+         END IF
+*
+*        Divide X by 1/(SL*SU) if doing so will not cause overflow.
+*
+         SCALE = SL*SU
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = IDAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL DRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DGECON
+*
+      END
diff --git a/src/lib/lapack/dgeequ.f b/src/lib/lapack/dgeequ.f
new file mode 100644
index 00000000..b703116e
--- /dev/null
+++ b/src/lib/lapack/dgeequ.f
@@ -0,0 +1,225 @@
+      SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEEQU computes row and column scalings intended to equilibrate an
+*  M-by-N matrix A and reduce its condition number.  R returns the row
+*  scale factors and C the column scale factors, chosen to try to make
+*  the largest element in each row and column of the matrix B with
+*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+*  number and BIGNUM = largest safe number.  Use of these scaling
+*  factors is not guaranteed to reduce the condition number of A but
+*  works well in practice.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The M-by-N matrix whose equilibration factors are
+*          to be computed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  R       (output) DOUBLE PRECISION array, dimension (M)
+*          If INFO = 0 or INFO > M, R contains the row scale factors
+*          for A.
+*
+*  C       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0,  C contains the column scale factors for A.
+*
+*  ROWCND  (output) DOUBLE PRECISION
+*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the
+*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and
+*          AMAX is neither too large nor too small, it is not worth
+*          scaling by R.
+*
+*  COLCND  (output) DOUBLE PRECISION
+*          If INFO = 0, COLCND contains the ratio of the smallest
+*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not
+*          worth scaling by C.
+*
+*  AMAX    (output) DOUBLE PRECISION
+*          Absolute value of largest matrix element.  If AMAX is very
+*          close to overflow or very close to underflow, the matrix
+*          should be scaled.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i,  and i is
+*                <= M:  the i-th row of A is exactly zero
+*                >  M:  the (i-M)-th column of A is exactly zero
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   BIGNUM, RCMAX, RCMIN, SMLNUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEEQU', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         ROWCND = ONE
+         COLCND = ONE
+         AMAX = ZERO
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+*     Compute row scale factors.
+*
+      DO 10 I = 1, M
+         R( I ) = ZERO
+   10 CONTINUE
+*
+*     Find the maximum element in each row.
+*
+      DO 30 J = 1, N
+         DO 20 I = 1, M
+            R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 40 I = 1, M
+         RCMAX = MAX( RCMAX, R( I ) )
+         RCMIN = MIN( RCMIN, R( I ) )
+   40 CONTINUE
+      AMAX = RCMAX
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 50 I = 1, M
+            IF( R( I ).EQ.ZERO ) THEN
+               INFO = I
+               RETURN
+            END IF
+   50    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 60 I = 1, M
+            R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+   60    CONTINUE
+*
+*        Compute ROWCND = min(R(I)) / max(R(I))
+*
+         ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+*     Compute column scale factors
+*
+      DO 70 J = 1, N
+         C( J ) = ZERO
+   70 CONTINUE
+*
+*     Find the maximum element in each column,
+*     assuming the row scaling computed above.
+*
+      DO 90 J = 1, N
+         DO 80 I = 1, M
+            C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Find the maximum and minimum scale factors.
+*
+      RCMIN = BIGNUM
+      RCMAX = ZERO
+      DO 100 J = 1, N
+         RCMIN = MIN( RCMIN, C( J ) )
+         RCMAX = MAX( RCMAX, C( J ) )
+  100 CONTINUE
+*
+      IF( RCMIN.EQ.ZERO ) THEN
+*
+*        Find the first zero scale factor and return an error code.
+*
+         DO 110 J = 1, N
+            IF( C( J ).EQ.ZERO ) THEN
+               INFO = M + J
+               RETURN
+            END IF
+  110    CONTINUE
+      ELSE
+*
+*        Invert the scale factors.
+*
+         DO 120 J = 1, N
+            C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+  120    CONTINUE
+*
+*        Compute COLCND = min(C(J)) / max(C(J))
+*
+         COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+      END IF
+*
+      RETURN
+*
+*     End of DGEEQU
+*
+      END
diff --git a/src/lib/lapack/dgees.f b/src/lib/lapack/dgees.f
new file mode 100644
index 00000000..96ba8019
--- /dev/null
+++ b/src/lib/lapack/dgees.f
@@ -0,0 +1,434 @@
+      SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
+     $                  VS, LDVS, WORK, LWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVS, SORT
+      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEES computes for an N-by-N real nonsymmetric matrix A, the
+*  eigenvalues, the real Schur form T, and, optionally, the matrix of
+*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
+*
+*  Optionally, it also orders the eigenvalues on the diagonal of the
+*  real Schur form so that selected eigenvalues are at the top left.
+*  The leading columns of Z then form an orthonormal basis for the
+*  invariant subspace corresponding to the selected eigenvalues.
+*
+*  A matrix is in real Schur form if it is upper quasi-triangular with
+*  1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
+*  form
+*          [  a  b  ]
+*          [  c  a  ]
+*
+*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+*  Arguments
+*  =========
+*
+*  JOBVS   (input) CHARACTER*1
+*          = 'N': Schur vectors are not computed;
+*          = 'V': Schur vectors are computed.
+*
+*  SORT    (input) CHARACTER*1
+*          Specifies whether or not to order the eigenvalues on the
+*          diagonal of the Schur form.
+*          = 'N': Eigenvalues are not ordered;
+*          = 'S': Eigenvalues are ordered (see SELECT).
+*
+*  SELECT  (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
+*          SELECT must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'S', SELECT is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          If SORT = 'N', SELECT is not referenced.
+*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
+*          conjugate pair of eigenvalues is selected, then both complex
+*          eigenvalues are selected.
+*          Note that a selected complex eigenvalue may no longer
+*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+*          ordering may change the value of complex eigenvalues
+*          (especially if the eigenvalue is ill-conditioned); in this
+*          case INFO is set to N+2 (see INFO below).
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten by its real Schur form T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  SDIM    (output) INTEGER
+*          If SORT = 'N', SDIM = 0.
+*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+*                         for which SELECT is true. (Complex conjugate
+*                         pairs for which SELECT is true for either
+*                         eigenvalue count as 2.)
+*
+*  WR      (output) DOUBLE PRECISION array, dimension (N)
+*  WI      (output) DOUBLE PRECISION array, dimension (N)
+*          WR and WI contain the real and imaginary parts,
+*          respectively, of the computed eigenvalues in the same order
+*          that they appear on the diagonal of the output Schur form T.
+*          Complex conjugate pairs of eigenvalues will appear
+*          consecutively with the eigenvalue having the positive
+*          imaginary part first.
+*
+*  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)
+*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+*          vectors.
+*          If JOBVS = 'N', VS is not referenced.
+*
+*  LDVS    (input) INTEGER
+*          The leading dimension of the array VS.  LDVS >= 1; if
+*          JOBVS = 'V', LDVS >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,3*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          Not referenced if SORT = 'N'.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*          > 0: if INFO = i, and i is
+*             <= N: the QR algorithm failed to compute all the
+*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+*                   contain those eigenvalues which have converged; if
+*                   JOBVS = 'V', VS contains the matrix which reduces A
+*                   to its partially converged Schur form.
+*             = N+1: the eigenvalues could not be reordered because some
+*                   eigenvalues were too close to separate (the problem
+*                   is very ill-conditioned);
+*             = N+2: after reordering, roundoff changed values of some
+*                   complex eigenvalues so that leading eigenvalues in
+*                   the Schur form no longer satisfy SELECT=.TRUE.  This
+*                   could also be caused by underflow due to scaling.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
+     $                   WANTVS
+      INTEGER            HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+     $                   IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
+     $                   DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVS = LSAME( JOBVS, 'V' )
+      WANTST = LSAME( SORT, 'S' )
+      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+         INFO = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by DHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 3*N
+*
+            CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+     $             WORK, -1, IEVAL )
+            HSWORK = WORK( 1 )
+*
+            IF( .NOT.WANTVS ) THEN
+               MAXWRK = MAX( MAXWRK, N + HSWORK )
+            ELSE
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'DORGHR', ' ', N, 1, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + HSWORK )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEES ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Workspace: need N)
+*
+      IBAL = 1
+      CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+*     Reduce to upper Hessenberg form
+*     (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+      ITAU = N + IBAL
+      IWRK = N + ITAU
+      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+*        Generate orthogonal matrix in VS
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+      END IF
+*
+      SDIM = 0
+*
+*     Perform QR iteration, accumulating Schur vectors in VS if desired
+*     (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+      IWRK = ITAU
+      CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+      IF( IEVAL.GT.0 )
+     $   INFO = IEVAL
+*
+*     Sort eigenvalues if desired
+*
+      IF( WANTST .AND. INFO.EQ.0 ) THEN
+         IF( SCALEA ) THEN
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+         END IF
+         DO 10 I = 1, N
+            BWORK( I ) = SELECT( WR( I ), WI( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues and transform Schur vectors
+*        (Workspace: none needed)
+*
+         CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+     $                SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+     $                ICOND )
+         IF( ICOND.GT.0 )
+     $      INFO = N + ICOND
+      END IF
+*
+      IF( WANTVS ) THEN
+*
+*        Undo balancing
+*        (Workspace: need N)
+*
+         CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+     $                IERR )
+      END IF
+*
+      IF( SCALEA ) THEN
+*
+*        Undo scaling for the Schur form of A
+*
+         CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL DCOPY( N, A, LDA+1, WR, 1 )
+         IF( CSCALE.EQ.SMLNUM ) THEN
+*
+*           If scaling back towards underflow, adjust WI if an
+*           offdiagonal element of a 2-by-2 block in the Schur form
+*           underflows.
+*
+            IF( IEVAL.GT.0 ) THEN
+               I1 = IEVAL + 1
+               I2 = IHI - 1
+               CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI,
+     $                      MAX( ILO-1, 1 ), IERR )
+            ELSE IF( WANTST ) THEN
+               I1 = 1
+               I2 = N - 1
+            ELSE
+               I1 = ILO
+               I2 = IHI - 1
+            END IF
+            INXT = I1 - 1
+            DO 20 I = I1, I2
+               IF( I.LT.INXT )
+     $            GO TO 20
+               IF( WI( I ).EQ.ZERO ) THEN
+                  INXT = I + 1
+               ELSE
+                  IF( A( I+1, I ).EQ.ZERO ) THEN
+                     WI( I ) = ZERO
+                     WI( I+1 ) = ZERO
+                  ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+     $                     ZERO ) THEN
+                     WI( I ) = ZERO
+                     WI( I+1 ) = ZERO
+                     IF( I.GT.1 )
+     $                  CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+                     IF( N.GT.I+1 )
+     $                  CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
+     $                              A( I+1, I+2 ), LDA )
+                     IF( WANTVS ) THEN
+                        CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+                     END IF
+                     A( I, I+1 ) = A( I+1, I )
+                     A( I+1, I ) = ZERO
+                  END IF
+                  INXT = I + 2
+               END IF
+   20       CONTINUE
+         END IF
+*
+*        Undo scaling for the imaginary part of the eigenvalues
+*
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+     $                WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+      END IF
+*
+      IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+*        Check if reordering successful
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 30 I = 1, N
+            CURSL = SELECT( WR( I ), WI( I ) )
+            IF( WI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   30    CONTINUE
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of DGEES
+*
+      END
diff --git a/src/lib/lapack/dgeesx.f b/src/lib/lapack/dgeesx.f
new file mode 100644
index 00000000..deb30ab2
--- /dev/null
+++ b/src/lib/lapack/dgeesx.f
@@ -0,0 +1,527 @@
+      SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
+     $                   WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
+     $                   IWORK, LIWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVS, SENSE, SORT
+      INTEGER            INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
+      DOUBLE PRECISION   RCONDE, RCONDV
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEESX computes for an N-by-N real nonsymmetric matrix A, the
+*  eigenvalues, the real Schur form T, and, optionally, the matrix of
+*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
+*
+*  Optionally, it also orders the eigenvalues on the diagonal of the
+*  real Schur form so that selected eigenvalues are at the top left;
+*  computes a reciprocal condition number for the average of the
+*  selected eigenvalues (RCONDE); and computes a reciprocal condition
+*  number for the right invariant subspace corresponding to the
+*  selected eigenvalues (RCONDV).  The leading columns of Z form an
+*  orthonormal basis for this invariant subspace.
+*
+*  For further explanation of the reciprocal condition numbers RCONDE
+*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
+*  these quantities are called s and sep respectively).
+*
+*  A real matrix is in real Schur form if it is upper quasi-triangular
+*  with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
+*  the form
+*            [  a  b  ]
+*            [  c  a  ]
+*
+*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+*  Arguments
+*  =========
+*
+*  JOBVS   (input) CHARACTER*1
+*          = 'N': Schur vectors are not computed;
+*          = 'V': Schur vectors are computed.
+*
+*  SORT    (input) CHARACTER*1
+*          Specifies whether or not to order the eigenvalues on the
+*          diagonal of the Schur form.
+*          = 'N': Eigenvalues are not ordered;
+*          = 'S': Eigenvalues are ordered (see SELECT).
+*
+*  SELECT  (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
+*          SELECT must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'S', SELECT is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          If SORT = 'N', SELECT is not referenced.
+*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a
+*          complex conjugate pair of eigenvalues is selected, then both
+*          are.  Note that a selected complex eigenvalue may no longer
+*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+*          ordering may change the value of complex eigenvalues
+*          (especially if the eigenvalue is ill-conditioned); in this
+*          case INFO may be set to N+3 (see INFO below).
+*
+*  SENSE   (input) CHARACTER*1
+*          Determines which reciprocal condition numbers are computed.
+*          = 'N': None are computed;
+*          = 'E': Computed for average of selected eigenvalues only;
+*          = 'V': Computed for selected right invariant subspace only;
+*          = 'B': Computed for both.
+*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A is overwritten by its real Schur form T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  SDIM    (output) INTEGER
+*          If SORT = 'N', SDIM = 0.
+*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+*                         for which SELECT is true. (Complex conjugate
+*                         pairs for which SELECT is true for either
+*                         eigenvalue count as 2.)
+*
+*  WR      (output) DOUBLE PRECISION array, dimension (N)
+*  WI      (output) DOUBLE PRECISION array, dimension (N)
+*          WR and WI contain the real and imaginary parts, respectively,
+*          of the computed eigenvalues, in the same order that they
+*          appear on the diagonal of the output Schur form T.  Complex
+*          conjugate pairs of eigenvalues appear consecutively with the
+*          eigenvalue having the positive imaginary part first.
+*
+*  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)
+*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+*          vectors.
+*          If JOBVS = 'N', VS is not referenced.
+*
+*  LDVS    (input) INTEGER
+*          The leading dimension of the array VS.  LDVS >= 1, and if
+*          JOBVS = 'V', LDVS >= N.
+*
+*  RCONDE  (output) DOUBLE PRECISION
+*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal
+*          condition number for the average of the selected eigenvalues.
+*          Not referenced if SENSE = 'N' or 'V'.
+*
+*  RCONDV  (output) DOUBLE PRECISION
+*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal
+*          condition number for the selected right invariant subspace.
+*          Not referenced if SENSE = 'N' or 'E'.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,3*N).
+*          Also, if SENSE = 'E' or 'V' or 'B',
+*          LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
+*          selected eigenvalues computed by this routine.  Note that
+*          N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
+*          returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
+*          'B' this may not be large enough.
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates upper bounds on the optimal sizes of the
+*          arrays WORK and IWORK, returns these values as the first
+*          entries of the WORK and IWORK arrays, and no error messages
+*          related to LWORK or LIWORK are issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
+*          Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
+*          only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
+*          may not be large enough.
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates upper bounds on the optimal sizes of
+*          the arrays WORK and IWORK, returns these values as the first
+*          entries of the WORK and IWORK arrays, and no error messages
+*          related to LWORK or LIWORK are issued by XERBLA.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          Not referenced if SORT = 'N'.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*          > 0: if INFO = i, and i is
+*             <= N: the QR algorithm failed to compute all the
+*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+*                   contain those eigenvalues which have converged; if
+*                   JOBVS = 'V', VS contains the transformation which
+*                   reduces A to its partially converged Schur form.
+*             = N+1: the eigenvalues could not be reordered because some
+*                   eigenvalues were too close to separate (the problem
+*                   is very ill-conditioned);
+*             = N+2: after reordering, roundoff changed values of some
+*                   complex eigenvalues so that leading eigenvalues in
+*                   the Schur form no longer satisfy SELECT=.TRUE.  This
+*                   could also be caused by underflow due to scaling.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
+     $                   WANTSE, WANTSN, WANTST, WANTSV, WANTVS
+      INTEGER            HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+     $                   IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK,
+     $                   MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
+     $                   DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      WANTVS = LSAME( JOBVS, 'V' )
+      WANTST = LSAME( SORT, 'S' )
+      WANTSN = LSAME( SENSE, 'N' )
+      WANTSE = LSAME( SENSE, 'E' )
+      WANTSV = LSAME( SENSE, 'V' )
+      WANTSB = LSAME( SENSE, 'B' )
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+     $         ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+         INFO = -12
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "RWorkspace:" describe the
+*       minimal amount of real workspace needed at that point in the
+*       code, as well as the preferred amount for good performance.
+*       IWorkspace refers to integer workspace.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by DHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.
+*       If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
+*       depends on SDIM, which is computed by the routine DTRSEN later
+*       in the code.)
+*
+      IF( INFO.EQ.0 ) THEN
+         LIWRK = 1
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            LWRK = 1
+         ELSE
+            MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 3*N
+*
+            CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+     $             WORK, -1, IEVAL )
+            HSWORK = WORK( 1 )
+*
+            IF( .NOT.WANTVS ) THEN
+               MAXWRK = MAX( MAXWRK, N + HSWORK )
+            ELSE
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'DORGHR', ' ', N, 1, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + HSWORK )
+            END IF
+            LWRK = MAXWRK
+            IF( .NOT.WANTSN )
+     $         LWRK = MAX( LWRK, N + ( N*N )/2 )
+            IF( WANTSV .OR. WANTSB )
+     $         LIWRK = ( N*N )/4
+         END IF
+         IWORK( 1 ) = LIWRK
+         WORK( 1 ) = LWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -16
+         ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+            INFO = -18
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEESX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (RWorkspace: need N)
+*
+      IBAL = 1
+      CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+*     Reduce to upper Hessenberg form
+*     (RWorkspace: need 3*N, prefer 2*N+N*NB)
+*
+      ITAU = N + IBAL
+      IWRK = N + ITAU
+      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+*        Generate orthogonal matrix in VS
+*        (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+      END IF
+*
+      SDIM = 0
+*
+*     Perform QR iteration, accumulating Schur vectors in VS if desired
+*     (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
+*
+      IWRK = ITAU
+      CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+      IF( IEVAL.GT.0 )
+     $   INFO = IEVAL
+*
+*     Sort eigenvalues if desired
+*
+      IF( WANTST .AND. INFO.EQ.0 ) THEN
+         IF( SCALEA ) THEN
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+         END IF
+         DO 10 I = 1, N
+            BWORK( I ) = SELECT( WR( I ), WI( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues, transform Schur vectors, and compute
+*        reciprocal condition numbers
+*        (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
+*                     otherwise, need N )
+*        (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
+*                     otherwise, need 0 )
+*
+         CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+     $                SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
+     $                IWORK, LIWORK, ICOND )
+         IF( .NOT.WANTSN )
+     $      MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
+         IF( ICOND.EQ.-15 ) THEN
+*
+*           Not enough real workspace
+*
+            INFO = -16
+         ELSE IF( ICOND.EQ.-17 ) THEN
+*
+*           Not enough integer workspace
+*
+            INFO = -18
+         ELSE IF( ICOND.GT.0 ) THEN
+*
+*           DTRSEN failed to reorder or to restore standard Schur form
+*
+            INFO = ICOND + N
+         END IF
+      END IF
+*
+      IF( WANTVS ) THEN
+*
+*        Undo balancing
+*        (RWorkspace: need N)
+*
+         CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+     $                IERR )
+      END IF
+*
+      IF( SCALEA ) THEN
+*
+*        Undo scaling for the Schur form of A
+*
+         CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL DCOPY( N, A, LDA+1, WR, 1 )
+         IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
+            DUM( 1 ) = RCONDV
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+            RCONDV = DUM( 1 )
+         END IF
+         IF( CSCALE.EQ.SMLNUM ) THEN
+*
+*           If scaling back towards underflow, adjust WI if an
+*           offdiagonal element of a 2-by-2 block in the Schur form
+*           underflows.
+*
+            IF( IEVAL.GT.0 ) THEN
+               I1 = IEVAL + 1
+               I2 = IHI - 1
+               CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+     $                      IERR )
+            ELSE IF( WANTST ) THEN
+               I1 = 1
+               I2 = N - 1
+            ELSE
+               I1 = ILO
+               I2 = IHI - 1
+            END IF
+            INXT = I1 - 1
+            DO 20 I = I1, I2
+               IF( I.LT.INXT )
+     $            GO TO 20
+               IF( WI( I ).EQ.ZERO ) THEN
+                  INXT = I + 1
+               ELSE
+                  IF( A( I+1, I ).EQ.ZERO ) THEN
+                     WI( I ) = ZERO
+                     WI( I+1 ) = ZERO
+                  ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+     $                     ZERO ) THEN
+                     WI( I ) = ZERO
+                     WI( I+1 ) = ZERO
+                     IF( I.GT.1 )
+     $                  CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+                     IF( N.GT.I+1 )
+     $                  CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
+     $                              A( I+1, I+2 ), LDA )
+                     CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+                     A( I, I+1 ) = A( I+1, I )
+                     A( I+1, I ) = ZERO
+                  END IF
+                  INXT = I + 2
+               END IF
+   20       CONTINUE
+         END IF
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+     $                WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+      END IF
+*
+      IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+*        Check if reordering successful
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 30 I = 1, N
+            CURSL = SELECT( WR( I ), WI( I ) )
+            IF( WI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   30    CONTINUE
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      IF( WANTSV .OR. WANTSB ) THEN
+         IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) )
+      ELSE
+         IWORK( 1 ) = 1
+      END IF
+*
+      RETURN
+*
+*     End of DGEESX
+*
+      END
diff --git a/src/lib/lapack/dgeev.f b/src/lib/lapack/dgeev.f
new file mode 100644
index 00000000..50e08a9c
--- /dev/null
+++ b/src/lib/lapack/dgeev.f
@@ -0,0 +1,423 @@
+      SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
+     $                  LDVR, WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVL, JOBVR
+      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WI( * ), WORK( * ), WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEEV computes for an N-by-N real nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of A are computed.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  WR      (output) DOUBLE PRECISION array, dimension (N)
+*  WI      (output) DOUBLE PRECISION array, dimension (N)
+*          WR and WI contain the real and imaginary parts,
+*          respectively, of the computed eigenvalues.  Complex
+*          conjugate pairs of eigenvalues appear consecutively
+*          with the eigenvalue having the positive imaginary part
+*          first.
+*
+*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored one
+*          after another in the columns of VL, in the same order
+*          as their eigenvalues.
+*          If JOBVL = 'N', VL is not referenced.
+*          If the j-th eigenvalue is real, then u(j) = VL(:,j),
+*          the j-th column of VL.
+*          If the j-th and (j+1)-st eigenvalues form a complex
+*          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
+*          u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.  LDVL >= 1; if
+*          JOBVL = 'V', LDVL >= N.
+*
+*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors v(j) are stored one
+*          after another in the columns of VR, in the same order
+*          as their eigenvalues.
+*          If JOBVR = 'N', VR is not referenced.
+*          If the j-th eigenvalue is real, then v(j) = VR(:,j),
+*          the j-th column of VR.
+*          If the j-th and (j+1)-st eigenvalues form a complex
+*          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
+*          v(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1; if
+*          JOBVR = 'V', LDVR >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,3*N), and
+*          if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N.  For good
+*          performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = i, the QR algorithm failed to compute all the
+*                eigenvalues, and no eigenvectors have been computed;
+*                elements i+1:N of WR and WI contain eigenvalues which
+*                have converged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
+     $                   MAXWRK, MINWRK, NOUT
+      DOUBLE PRECISION   ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+     $                   SN
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY,
+     $                   DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX, ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE, DLAPY2, DNRM2
+      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
+     $                   DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVL = LSAME( JOBVL, 'V' )
+      WANTVR = LSAME( JOBVR, 'V' )
+      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by DHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+            IF( WANTVL ) THEN
+               MINWRK = 4*N
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'DORGHR', ' ', N, 1, N, -1 ) )
+               CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+     $                WORK, -1, INFO )
+               HSWORK = WORK( 1 )
+               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+               MAXWRK = MAX( MAXWRK, 4*N )
+            ELSE IF( WANTVR ) THEN
+               MINWRK = 4*N
+               MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+     $                       'DORGHR', ' ', N, 1, N, -1 ) )
+               CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+     $                WORK, -1, INFO )
+               HSWORK = WORK( 1 )
+               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+               MAXWRK = MAX( MAXWRK, 4*N )
+            ELSE 
+               MINWRK = 3*N
+               CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+     $                WORK, -1, INFO )
+               HSWORK = WORK( 1 )
+               MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+            END IF
+            MAXWRK = MAX( MAXWRK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix
+*     (Workspace: need N)
+*
+      IBAL = 1
+      CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+*     Reduce to upper Hessenberg form
+*     (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+      ITAU = IBAL + N
+      IWRK = ITAU + N
+      CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVL ) THEN
+*
+*        Want left eigenvectors
+*        Copy Householder vectors to VL
+*
+         SIDE = 'L'
+         CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+*        Generate orthogonal matrix in VL
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VL
+*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+         IF( WANTVR ) THEN
+*
+*           Want left and right eigenvectors
+*           Copy Schur vectors to VR
+*
+            SIDE = 'B'
+            CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+*        Generate orthogonal matrix in VR
+*        (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+         CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VR
+*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+      ELSE
+*
+*        Compute eigenvalues only
+*        (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+         IWRK = ITAU
+         CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from DHSEQR, then quit
+*
+      IF( INFO.GT.0 )
+     $   GO TO 50
+*
+      IF( WANTVL .OR. WANTVR ) THEN
+*
+*        Compute left and/or right eigenvectors
+*        (Workspace: need 4*N)
+*
+         CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), IERR )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*        (Workspace: need N)
+*
+         CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
+     $                IERR )
+*
+*        Normalize left eigenvectors and make largest component real
+*
+         DO 20 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
+     $               DNRM2( N, VL( 1, I+1 ), 1 ) )
+               CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
+               DO 10 K = 1, N
+                  WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
+   10          CONTINUE
+               K = IDAMAX( N, WORK( IWRK ), 1 )
+               CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+               CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+               VL( K, I+1 ) = ZERO
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*        (Workspace: need N)
+*
+         CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
+     $                IERR )
+*
+*        Normalize right eigenvectors and make largest component real
+*
+         DO 40 I = 1, N
+            IF( WI( I ).EQ.ZERO ) THEN
+               SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+            ELSE IF( WI( I ).GT.ZERO ) THEN
+               SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
+     $               DNRM2( N, VR( 1, I+1 ), 1 ) )
+               CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+               CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
+               DO 30 K = 1, N
+                  WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
+   30          CONTINUE
+               K = IDAMAX( N, WORK( IWRK ), 1 )
+               CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+               CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+               VR( K, I+1 ) = ZERO
+            END IF
+   40    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+   50 CONTINUE
+      IF( SCALEA ) THEN
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.GT.0 ) THEN
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+     $                   IERR )
+            CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+     $                   IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of DGEEV
+*
+      END
diff --git a/src/lib/lapack/dgegs.f b/src/lib/lapack/dgegs.f
new file mode 100644
index 00000000..85c32531
--- /dev/null
+++ b/src/lib/lapack/dgegs.f
@@ -0,0 +1,438 @@
+      SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
+     $                  ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
+     $                  LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVSL, JOBVSR
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+     $                   VSR( LDVSR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DGGES.
+*
+*  DGEGS computes the eigenvalues, real Schur form, and, optionally,
+*  left and or/right Schur vectors of a real matrix pair (A,B).
+*  Given two square matrices A and B, the generalized real Schur
+*  factorization has the form
+*
+*    A = Q*S*Z**T,  B = Q*T*Z**T
+*
+*  where Q and Z are orthogonal matrices, T is upper triangular, and S
+*  is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
+*  blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
+*  of eigenvalues of (A,B).  The columns of Q are the left Schur vectors
+*  and the columns of Z are the right Schur vectors.
+*
+*  If only the eigenvalues of (A,B) are needed, the driver routine
+*  DGEGV should be used instead.  See DGEGV for a description of the
+*  eigenvalues of the generalized nonsymmetric eigenvalue problem
+*  (GNEP).
+*
+*  Arguments
+*  =========
+*
+*  JOBVSL  (input) CHARACTER*1
+*          = 'N':  do not compute the left Schur vectors;
+*          = 'V':  compute the left Schur vectors (returned in VSL).
+*
+*  JOBVSR  (input) CHARACTER*1
+*          = 'N':  do not compute the right Schur vectors;
+*          = 'V':  compute the right Schur vectors (returned in VSR).
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the matrix A.
+*          On exit, the upper quasi-triangular matrix S from the
+*          generalized real Schur factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+*          On entry, the matrix B.
+*          On exit, the upper triangular matrix T from the generalized
+*          real Schur factorization.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
+*          The real parts of each scalar alpha defining an eigenvalue
+*          of GNEP.
+*
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
+*          The imaginary parts of each scalar alpha defining an
+*          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th
+*          eigenvalue is real; if positive, then the j-th and (j+1)-st
+*          eigenvalues are a complex conjugate pair, with
+*          ALPHAI(j+1) = -ALPHAI(j).
+*
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          The scalars beta that define the eigenvalues of GNEP.
+*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+*          beta = BETA(j) represent the j-th eigenvalue of the matrix
+*          pair (A,B), in one of the forms lambda = alpha/beta or
+*          mu = beta/alpha.  Since either lambda or mu may overflow,
+*          they should not, in general, be computed.
+*
+*  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)
+*          If JOBVSL = 'V', the matrix of left Schur vectors Q.
+*          Not referenced if JOBVSL = 'N'.
+*
+*  LDVSL   (input) INTEGER
+*          The leading dimension of the matrix VSL. LDVSL >=1, and
+*          if JOBVSL = 'V', LDVSL >= N.
+*
+*  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)
+*          If JOBVSR = 'V', the matrix of right Schur vectors Z.
+*          Not referenced if JOBVSR = 'N'.
+*
+*  LDVSR   (input) INTEGER
+*          The leading dimension of the matrix VSR. LDVSR >= 1, and
+*          if JOBVSR = 'V', LDVSR >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,4*N).
+*          For good performance, LWORK must generally be larger.
+*          To compute the optimal value of LWORK, call ILAENV to get
+*          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:
+*          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
+*          The optimal LWORK is  2*N + N*(NB+1).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1,...,N:
+*                The QZ iteration failed.  (A,B) are not in Schur
+*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+*                be correct for j=INFO+1,...,N.
+*          > N:  errors that usually indicate LAPACK problems:
+*                =N+1: error return from DGGBAL
+*                =N+2: error return from DGEQRF
+*                =N+3: error return from DORMQR
+*                =N+4: error return from DORGQR
+*                =N+5: error return from DGGHRD
+*                =N+6: error return from DHGEQZ (other than failed
+*                                                iteration)
+*                =N+7: error return from DGGBAK (computing VSL)
+*                =N+8: error return from DGGBAK (computing VSR)
+*                =N+9: error return from DLASCL (various places)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
+      INTEGER            ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN,
+     $                   LWKOPT, NB, NB1, NB2, NB3
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SAFMIN, SMLNUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY,
+     $                   DLASCL, DLASET, DORGQR, DORMQR, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+*     Test the input arguments
+*
+      LWKMIN = MAX( 4*N, 1 )
+      LWKOPT = LWKMIN
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      INFO = 0
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -16
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
+         NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
+         NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
+         NB = MAX( NB1, NB2, NB3 )
+         LOPT = 2*N + N*( NB+1 )
+         WORK( 1 ) = LOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEGS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
+      SAFMIN = DLAMCH( 'S' )
+      SMLNUM = N*SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+*     Permute the matrix to make it more nearly triangular
+*     Workspace layout:  (2*N words -- "work..." not actually used)
+*        left_permutation, right_permutation, work...
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWORK = IRIGHT + N
+      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+     $             WORK( IRIGHT ), WORK( IWORK ), IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 1
+         GO TO 10
+      END IF
+*
+*     Reduce B to triangular form, and initialize VSL and/or VSR
+*     Workspace layout:  ("work..." must have at least N words)
+*        left_permutation, right_permutation, tau, work...
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWORK
+      IWORK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWORK ), LWORK+1-IWORK, IINFO )
+      IF( IINFO.GE.0 )
+     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 2
+         GO TO 10
+      END IF
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
+     $             LWORK+1-IWORK, IINFO )
+      IF( IINFO.GE.0 )
+     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 3
+         GO TO 10
+      END IF
+*
+      IF( ILVSL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VSL( ILO+1, ILO ), LDVSL )
+         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
+     $                IINFO )
+         IF( IINFO.GE.0 )
+     $      LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 4
+            GO TO 10
+         END IF
+      END IF
+*
+      IF( ILVSR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IINFO )
+      IF( IINFO.NE.0 ) THEN
+         INFO = N + 5
+         GO TO 10
+      END IF
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     Workspace layout:  ("work..." must have at least 1 word)
+*        left_permutation, right_permutation, work...
+*
+      IWORK = ITAU
+      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $             WORK( IWORK ), LWORK+1-IWORK, IINFO )
+      IF( IINFO.GE.0 )
+     $   LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+      IF( IINFO.NE.0 ) THEN
+         IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
+            INFO = IINFO
+         ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
+            INFO = IINFO - N
+         ELSE
+            INFO = N + 6
+         END IF
+         GO TO 10
+      END IF
+*
+*     Apply permutation to VSL and VSR
+*
+      IF( ILVSL ) THEN
+         CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 7
+            GO TO 10
+         END IF
+      END IF
+      IF( ILVSR ) THEN
+         CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 8
+            GO TO 10
+         END IF
+      END IF
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+         CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
+         IF( IINFO.NE.0 ) THEN
+            INFO = N + 9
+            RETURN
+         END IF
+      END IF
+*
+   10 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DGEGS
+*
+      END
diff --git a/src/lib/lapack/dgehd2.f b/src/lib/lapack/dgehd2.f
new file mode 100644
index 00000000..28d1cc8d
--- /dev/null
+++ b/src/lib/lapack/dgehd2.f
@@ -0,0 +1,149 @@
+      SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
+*  an orthogonal similarity transformation:  Q' * A * Q = H .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          It is assumed that A is already upper triangular in rows
+*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*          set by a previous call to DGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= max(1,N).
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the n by n general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          elements below the first subdiagonal, with the array TAU,
+*          represent the orthogonal matrix Q as a product of elementary
+*          reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of (ihi-ilo) elementary
+*  reflectors
+*
+*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*  exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+*  The contents of A are illustrated by the following example, with
+*  n = 7, ilo = 2 and ihi = 6:
+*
+*  on entry,                        on exit,
+*
+*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
+*  (                         a )    (                          a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEHD2', -INFO )
+         RETURN
+      END IF
+*
+      DO 10 I = ILO, IHI - 1
+*
+*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+         CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+     $                TAU( I ) )
+         AII = A( I+1, I )
+         A( I+1, I ) = ONE
+*
+*        Apply H(i) to A(1:ihi,i+1:ihi) from the right
+*
+         CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+     $               A( 1, I+1 ), LDA, WORK )
+*
+*        Apply H(i) to A(i+1:ihi,i+1:n) from the left
+*
+         CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
+     $               A( I+1, I+1 ), LDA, WORK )
+*
+         A( I+1, I ) = AII
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of DGEHD2
+*
+      END
diff --git a/src/lib/lapack/dgehrd.f b/src/lib/lapack/dgehrd.f
new file mode 100644
index 00000000..339ee400
--- /dev/null
+++ b/src/lib/lapack/dgehrd.f
@@ -0,0 +1,273 @@
+      SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION  A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEHRD reduces a real general matrix A to upper Hessenberg form H by
+*  an orthogonal similarity transformation:  Q' * A * Q = H .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          It is assumed that A is already upper triangular in rows
+*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*          set by a previous call to DGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the N-by-N general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          elements below the first subdiagonal, with the array TAU,
+*          represent the orthogonal matrix Q as a product of elementary
+*          reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
+*          zero.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of (ihi-ilo) elementary
+*  reflectors
+*
+*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*  exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+*  The contents of A are illustrated by the following example, with
+*  n = 7, ilo = 2 and ihi = 6:
+*
+*  on entry,                        on exit,
+*
+*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
+*  (                         a )    (                          a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  This file is a slight modification of LAPACK-3.0's DGEHRD
+*  subroutine incorporating improvements proposed by Quintana-Orti and
+*  Van de Geijn (2005). 
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+      DOUBLE PRECISION  ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, 
+     $                     ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NH, NX
+      DOUBLE PRECISION  EI
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION  T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEHRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
+*
+      DO 10 I = 1, ILO - 1
+         TAU( I ) = ZERO
+   10 CONTINUE
+      DO 20 I = MAX( 1, IHI ), N - 1
+         TAU( I ) = ZERO
+   20 CONTINUE
+*
+*     Quick return if possible
+*
+      NH = IHI - ILO + 1
+      IF( NH.LE.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size
+*
+      NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+      NBMIN = 2
+      IWS = 1
+      IF( NB.GT.1 .AND. NB.LT.NH ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code
+*        (last block is always handled by unblocked code)
+*
+         NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+         IF( NX.LT.NH ) THEN
+*
+*           Determine if workspace is large enough for blocked code
+*
+            IWS = N*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  determine the
+*              minimum value of NB, and reduce NB or force use of
+*              unblocked code
+*
+               NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI,
+     $                 -1 ) )
+               IF( LWORK.GE.N*NBMIN ) THEN
+                  NB = LWORK / N
+               ELSE
+                  NB = 1
+               END IF
+            END IF
+         END IF
+      END IF
+      LDWORK = N
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
+*
+*        Use unblocked code below
+*
+         I = ILO
+*
+      ELSE
+*
+*        Use blocked code
+*
+         DO 40 I = ILO, IHI - 1 - NX, NB
+            IB = MIN( NB, IHI-I )
+*
+*           Reduce columns i:i+ib-1 to Hessenberg form, returning the
+*           matrices V and T of the block reflector H = I - V*T*V'
+*           which performs the reduction, and also the matrix Y = A*V*T
+*
+            CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
+     $                   WORK, LDWORK )
+*
+*           Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
+*           right, computing  A := A - Y * V'. V(i+ib,ib-1) must be set
+*           to 1
+*
+            EI = A( I+IB, I+IB-1 )
+            A( I+IB, I+IB-1 ) = ONE
+            CALL DGEMM( 'No transpose', 'Transpose', 
+     $                  IHI, IHI-I-IB+1,
+     $                  IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
+     $                  A( 1, I+IB ), LDA )
+            A( I+IB, I+IB-1 ) = EI
+*
+*           Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
+*           right
+*
+            CALL DTRMM( 'Right', 'Lower', 'Transpose',
+     $                  'Unit', I, IB-1,
+     $                  ONE, A( I+1, I ), LDA, WORK, LDWORK )
+            DO 30 J = 0, IB-2
+               CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
+     $                     A( 1, I+J+1 ), 1 )
+   30       CONTINUE
+*
+*           Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
+*           left
+*
+            CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                   'Columnwise',
+     $                   IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
+     $                   A( I+1, I+IB ), LDA, WORK, LDWORK )
+   40    CONTINUE
+      END IF
+*
+*     Use unblocked code to reduce the rest of the matrix
+*
+      CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+      WORK( 1 ) = IWS
+*
+      RETURN
+*
+*     End of DGEHRD
+*
+      END
diff --git a/src/lib/lapack/dgelq2.f b/src/lib/lapack/dgelq2.f
new file mode 100644
index 00000000..f3540505
--- /dev/null
+++ b/src/lib/lapack/dgelq2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELQ2 computes an LQ factorization of a real m by n matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m by min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELQ2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+         CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+     $                TAU( I ) )
+         IF( I.LT.M ) THEN
+*
+*           Apply H(i) to A(i+1:m,i:n) from the right
+*
+            AII = A( I, I )
+            A( I, I ) = ONE
+            CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+     $                  A( I+1, I ), LDA, WORK )
+            A( I, I ) = AII
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of DGELQ2
+*
+      END
diff --git a/src/lib/lapack/dgelqf.f b/src/lib/lapack/dgelqf.f
new file mode 100644
index 00000000..063a38ba
--- /dev/null
+++ b/src/lib/lapack/dgelqf.f
@@ -0,0 +1,195 @@
+      SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELQF computes an LQ factorization of a real M-by-N matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGELQ2, DLARFB, DLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+      LWKOPT = M*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially
+*
+         DO 10 I = 1, K - NX, NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the LQ factorization of the current block
+*           A(i:i+ib-1,i:n)
+*
+            CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+            IF( I+IB.LE.M ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(i+ib:m,i:n) from the right
+*
+               CALL DLARFB( 'Right', 'No transpose', 'Forward',
+     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
+     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K )
+     $   CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGELQF
+*
+      END
diff --git a/src/lib/lapack/dgels.f b/src/lib/lapack/dgels.f
new file mode 100644
index 00000000..4fa1e229
--- /dev/null
+++ b/src/lib/lapack/dgels.f
@@ -0,0 +1,422 @@
+      SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
+     $                  INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELS solves overdetermined or underdetermined real linear systems
+*  involving an M-by-N matrix A, or its transpose, using a QR or LQ
+*  factorization of A.  It is assumed that A has full rank.
+*
+*  The following options are provided:
+*
+*  1. If TRANS = 'N' and m >= n:  find the least squares solution of
+*     an overdetermined system, i.e., solve the least squares problem
+*                  minimize || B - A*X ||.
+*
+*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of
+*     an underdetermined system A * X = B.
+*
+*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
+*     an undetermined system A**T * X = B.
+*
+*  4. If TRANS = 'T' and m < n:  find the least squares solution of
+*     an overdetermined system, i.e., solve the least squares problem
+*                  minimize || B - A**T * X ||.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': the linear system involves A;
+*          = 'T': the linear system involves A**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of
+*          columns of the matrices B and X. NRHS >=0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*            if M >= N, A is overwritten by details of its QR
+*                       factorization as returned by DGEQRF;
+*            if M <  N, A is overwritten by details of its LQ
+*                       factorization as returned by DGELQF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the matrix B of right hand side vectors, stored
+*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+*          if TRANS = 'T'.
+*          On exit, if INFO = 0, B is overwritten by the solution
+*          vectors, stored columnwise:
+*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+*          squares solution vectors; the residual sum of squares for the
+*          solution in each column is given by the sum of squares of
+*          elements N+1 to M in that column;
+*          if TRANS = 'N' and m < n, rows 1 to N of B contain the
+*          minimum norm solution vectors;
+*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+*          minimum norm solution vectors;
+*          if TRANS = 'T' and m < n, rows 1 to M of B contain the
+*          least squares solution vectors; the residual sum of squares
+*          for the solution in each column is given by the sum of
+*          squares of elements M+1 to N in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= MAX(1,M,N).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >= max( 1, MN + max( MN, NRHS ) ).
+*          For optimal performance,
+*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
+*          where MN = min(M,N) and NB is the optimum block size.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO =  i, the i-th diagonal element of the
+*                triangular factor of A is zero, so that A does not have
+*                full rank; the least squares solution could not be
+*                computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, TPSD
+      INTEGER            BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR,
+     $                   DTRTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -6
+      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
+     $          THEN
+         INFO = -10
+      END IF
+*
+*     Figure out optimal block size
+*
+      IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
+*
+         TPSD = .TRUE.
+         IF( LSAME( TRANS, 'N' ) )
+     $      TPSD = .FALSE.
+*
+         IF( M.GE.N ) THEN
+            NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N,
+     $              -1 ) )
+            END IF
+         ELSE
+            NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+            IF( TPSD ) THEN
+               NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M,
+     $              -1 ) )
+            ELSE
+               NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M,
+     $              -1 ) )
+            END IF
+         END IF
+*
+         WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
+         WORK( 1 ) = DBLE( WSIZE )
+*
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELS ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         GO TO 50
+      END IF
+*
+      BROW = M
+      IF( TPSD )
+     $   BROW = N
+      BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+     $                INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+     $                INFO )
+         IBSCL = 2
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        compute QR factorization of A
+*
+         CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+     $                INFO )
+*
+*        workspace at least N, optimally N*NB
+*
+         IF( .NOT.TPSD ) THEN
+*
+*           Least-Squares Problem min || A * X - B ||
+*
+*           B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+            CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
+     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+     $                   INFO )
+*
+*           workspace at least NRHS, optimally NRHS*NB
+*
+*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
+*
+            CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
+     $                   A, LDA, B, LDB, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+               RETURN
+            END IF
+*
+            SCLLEN = N
+*
+         ELSE
+*
+*           Overdetermined system of equations A' * X = B
+*
+*           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
+*
+            CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+     $                   A, LDA, B, LDB, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+               RETURN
+            END IF
+*
+*           B(N+1:M,1:NRHS) = ZERO
+*
+            DO 20 J = 1, NRHS
+               DO 10 I = N + 1, M
+                  B( I, J ) = ZERO
+   10          CONTINUE
+   20       CONTINUE
+*
+*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+            CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
+     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+     $                   INFO )
+*
+*           workspace at least NRHS, optimally NRHS*NB
+*
+            SCLLEN = M
+*
+         END IF
+*
+      ELSE
+*
+*        Compute LQ factorization of A
+*
+         CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+     $                INFO )
+*
+*        workspace at least M, optimally M*NB.
+*
+         IF( .NOT.TPSD ) THEN
+*
+*           underdetermined system of equations A * X = B
+*
+*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+            CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
+     $                   A, LDA, B, LDB, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+               RETURN
+            END IF
+*
+*           B(M+1:N,1:NRHS) = 0
+*
+            DO 40 J = 1, NRHS
+               DO 30 I = M + 1, N
+                  B( I, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+*
+*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
+*
+            CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
+     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+     $                   INFO )
+*
+*           workspace at least NRHS, optimally NRHS*NB
+*
+            SCLLEN = N
+*
+         ELSE
+*
+*           overdetermined system min || A' * X - B ||
+*
+*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+            CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
+     $                   WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+     $                   INFO )
+*
+*           workspace at least NRHS, optimally NRHS*NB
+*
+*           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
+*
+            CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
+     $                   A, LDA, B, LDB, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+               RETURN
+            END IF
+*
+            SCLLEN = M
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+     $                INFO )
+      END IF
+*
+   50 CONTINUE
+      WORK( 1 ) = DBLE( WSIZE )
+*
+      RETURN
+*
+*     End of DGELS
+*
+      END
diff --git a/src/lib/lapack/dgelss.f b/src/lib/lapack/dgelss.f
new file mode 100644
index 00000000..f024e138
--- /dev/null
+++ b/src/lib/lapack/dgelss.f
@@ -0,0 +1,617 @@
+      SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELSS computes the minimum norm solution to a real linear least
+*  squares problem:
+*
+*  Minimize 2-norm(| b - A*x |).
+*
+*  using the singular value decomposition (SVD) of A. A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
+*  X.
+*
+*  The effective rank of A is determined by treating as zero those
+*  singular values which are less than RCOND times the largest singular
+*  value.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X. NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the first min(m,n) rows of A are overwritten with
+*          its right singular vectors, stored rowwise.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the M-by-NRHS right hand side matrix B.
+*          On exit, B is overwritten by the N-by-NRHS solution
+*          matrix X.  If m >= n and RANK = n, the residual
+*          sum-of-squares for the solution in the i-th column is given
+*          by the sum of squares of elements n+1:m in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,max(M,N)).
+*
+*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The singular values of A in decreasing order.
+*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
+*
+*  RCOND   (input) DOUBLE PRECISION
+*          RCOND is used to determine the effective rank of A.
+*          Singular values S(i) <= RCOND*S(1) are treated as zero.
+*          If RCOND < 0, machine precision is used instead.
+*
+*  RANK    (output) INTEGER
+*          The effective rank of A, i.e., the number of singular values
+*          which are greater than RCOND*S(1).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= 1, and also:
+*          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  the algorithm for computing the SVD failed to converge;
+*                if INFO = i, i off-diagonal elements of an intermediate
+*                bidiagonal form did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL,
+     $                   ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
+     $                   MAXWRK, MINMN, MINWRK, MM, MNTHR
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   VDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV,
+     $                   DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR,
+     $                   DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      MAXMN = MAX( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         MINWRK = 1
+         MAXWRK = 1
+         IF( MINMN.GT.0 ) THEN
+            MM = M
+            MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 )
+            IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+*              Path 1a - overdetermined, with many more rows than
+*                        columns
+*
+               MM = N
+               MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M,
+     $                       N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT',
+     $                       M, NRHS, N, -1 ) )
+            END IF
+            IF( M.GE.N ) THEN
+*
+*              Path 1 - overdetermined or exactly determined
+*
+*              Compute workspace needed for DBDSQR
+*
+               BDSPAC = MAX( 1, 5*N )
+               MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+     $                       'DGEBRD', ' ', MM, N, -1, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR',
+     $                       'QLT', MM, NRHS, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+     $                       'DORGBR', 'P', N, N, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, BDSPAC )
+               MAXWRK = MAX( MAXWRK, N*NRHS )
+               MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC )
+               MAXWRK = MAX( MINWRK, MAXWRK )
+            END IF
+            IF( N.GT.M ) THEN
+*
+*              Compute workspace needed for DBDSQR
+*
+               BDSPAC = MAX( 1, 5*M )
+               MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
+               IF( N.GE.MNTHR ) THEN
+*
+*                 Path 2a - underdetermined, with many more columns
+*                 than rows
+*
+                  MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+     $                                  -1 )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+     $                          'DGEBRD', ' ', M, M, -1, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+     $                          'DORMBR', 'QLT', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + 4*M +
+     $                          ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M,
+     $                          M, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC )
+                  IF( NRHS.GT.1 ) THEN
+                     MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+                  ELSE
+                     MAXWRK = MAX( MAXWRK, M*M + 2*M )
+                  END IF
+                  MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ',
+     $                          'LT', N, NRHS, M, -1 ) )
+               ELSE
+*
+*                 Path 2 - underdetermined
+*
+                  MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M,
+     $                     N, -1, -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR',
+     $                          'QLT', M, NRHS, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR',
+     $                          'P', M, N, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, BDSPAC )
+                  MAXWRK = MAX( MAXWRK, N*NRHS )
+               END IF
+            END IF
+            MAXWRK = MAX( MINWRK, MAXWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+     $      INFO = -12
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELSS', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      EPS = DLAMCH( 'P' )
+      SFMIN = DLAMCH( 'S' )
+      SMLNUM = SFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     Overdetermined case
+*
+      IF( M.GE.N ) THEN
+*
+*        Path 1 - overdetermined or exactly determined
+*
+         MM = M
+         IF( M.GE.MNTHR ) THEN
+*
+*           Path 1a - overdetermined, with many more rows than columns
+*
+            MM = N
+            ITAU = 1
+            IWORK = ITAU + N
+*
+*           Compute A=Q*R
+*           (Workspace: need 2*N, prefer N+N*NB)
+*
+            CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                   LWORK-IWORK+1, INFO )
+*
+*           Multiply B by transpose(Q)
+*           (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+            CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+     $                   LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*           Zero out below R
+*
+            IF( N.GT.1 )
+     $         CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+         END IF
+*
+         IE = 1
+         ITAUQ = IE + N
+         ITAUP = ITAUQ + N
+         IWORK = ITAUP + N
+*
+*        Bidiagonalize R in A
+*        (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+         CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of R
+*        (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors of R in A
+*        (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+         CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IWORK = IE + N
+*
+*        Perform bidiagonal QR iteration
+*          multiply B by transpose of left singular vectors
+*          compute right singular vectors in A
+*        (Workspace: need BDSPAC)
+*
+         CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, WORK( IWORK ), INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 70
+*
+*        Multiply B by reciprocals of singular values
+*
+         THR = MAX( RCOND*S( 1 ), SFMIN )
+         IF( RCOND.LT.ZERO )
+     $      THR = MAX( EPS*S( 1 ), SFMIN )
+         RANK = 0
+         DO 10 I = 1, N
+            IF( S( I ).GT.THR ) THEN
+               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+            END IF
+   10    CONTINUE
+*
+*        Multiply B by right singular vectors
+*        (Workspace: need N, prefer N*NRHS)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
+     $                  WORK, LDB )
+            CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
+         ELSE IF( NRHS.GT.1 ) THEN
+            CHUNK = LWORK / N
+            DO 20 I = 1, NRHS, CHUNK
+               BL = MIN( NRHS-I+1, CHUNK )
+               CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
+     $                     LDB, ZERO, WORK, N )
+               CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+   20       CONTINUE
+         ELSE
+            CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+            CALL DCOPY( N, WORK, 1, B, 1 )
+         END IF
+*
+      ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+     $         MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
+*
+*        Path 2a - underdetermined, with many more columns than rows
+*        and sufficient workspace for an efficient algorithm
+*
+         LDWORK = M
+         IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+     $       M*LDA+M+M*NRHS ) )LDWORK = LDA
+         ITAU = 1
+         IWORK = M + 1
+*
+*        Compute A=L*Q
+*        (Workspace: need 2*M, prefer M+M*NB)
+*
+         CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+         IL = IWORK
+*
+*        Copy L to WORK(IL), zeroing out above it
+*
+         CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+         CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+     $                LDWORK )
+         IE = IL + LDWORK*M
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize L in WORK(IL)
+*        (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+         CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+     $                WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors of L
+*        (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+     $                WORK( ITAUQ ), B, LDB, WORK( IWORK ),
+     $                LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors of R in WORK(IL)
+*        (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
+*
+         CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IWORK = IE + M
+*
+*        Perform bidiagonal QR iteration,
+*           computing right singular vectors of L in WORK(IL) and
+*           multiplying B by transpose of left singular vectors
+*        (Workspace: need M*M+M+BDSPAC)
+*
+         CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
+     $                LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 70
+*
+*        Multiply B by reciprocals of singular values
+*
+         THR = MAX( RCOND*S( 1 ), SFMIN )
+         IF( RCOND.LT.ZERO )
+     $      THR = MAX( EPS*S( 1 ), SFMIN )
+         RANK = 0
+         DO 30 I = 1, M
+            IF( S( I ).GT.THR ) THEN
+               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+            END IF
+   30    CONTINUE
+         IWORK = IE
+*
+*        Multiply B by right singular vectors of L in WORK(IL)
+*        (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
+*
+         IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
+            CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
+     $                  B, LDB, ZERO, WORK( IWORK ), LDB )
+            CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
+         ELSE IF( NRHS.GT.1 ) THEN
+            CHUNK = ( LWORK-IWORK+1 ) / M
+            DO 40 I = 1, NRHS, CHUNK
+               BL = MIN( NRHS-I+1, CHUNK )
+               CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
+     $                     B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
+               CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+     $                      LDB )
+   40       CONTINUE
+         ELSE
+            CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
+     $                  1, ZERO, WORK( IWORK ), 1 )
+            CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+         END IF
+*
+*        Zero out below first M rows of B
+*
+         CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+         IWORK = ITAU + M
+*
+*        Multiply transpose(Q) by B
+*        (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+         CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+     $                LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+      ELSE
+*
+*        Path 2 - remaining underdetermined cases
+*
+         IE = 1
+         ITAUQ = IE + M
+         ITAUP = ITAUQ + M
+         IWORK = ITAUP + M
+*
+*        Bidiagonalize A
+*        (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+         CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                INFO )
+*
+*        Multiply B by transpose of left bidiagonalizing vectors
+*        (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+         CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+     $                B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+*        Generate right bidiagonalizing vectors in A
+*        (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+         CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                WORK( IWORK ), LWORK-IWORK+1, INFO )
+         IWORK = IE + M
+*
+*        Perform bidiagonal QR iteration,
+*           computing right singular vectors of A in A and
+*           multiplying B by transpose of left singular vectors
+*        (Workspace: need BDSPAC)
+*
+         CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+     $                1, B, LDB, WORK( IWORK ), INFO )
+         IF( INFO.NE.0 )
+     $      GO TO 70
+*
+*        Multiply B by reciprocals of singular values
+*
+         THR = MAX( RCOND*S( 1 ), SFMIN )
+         IF( RCOND.LT.ZERO )
+     $      THR = MAX( EPS*S( 1 ), SFMIN )
+         RANK = 0
+         DO 50 I = 1, M
+            IF( S( I ).GT.THR ) THEN
+               CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+               RANK = RANK + 1
+            ELSE
+               CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+            END IF
+   50    CONTINUE
+*
+*        Multiply B by right singular vectors of A
+*        (Workspace: need N, prefer N*NRHS)
+*
+         IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+            CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
+     $                  WORK, LDB )
+            CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
+         ELSE IF( NRHS.GT.1 ) THEN
+            CHUNK = LWORK / N
+            DO 60 I = 1, NRHS, CHUNK
+               BL = MIN( NRHS-I+1, CHUNK )
+               CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
+     $                     LDB, ZERO, WORK, N )
+               CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+   60       CONTINUE
+         ELSE
+            CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+            CALL DCOPY( N, WORK, 1, B, 1 )
+         END IF
+      END IF
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of DGELSS
+*
+      END
diff --git a/src/lib/lapack/dgelsx.f b/src/lib/lapack/dgelsx.f
new file mode 100644
index 00000000..a597cd47
--- /dev/null
+++ b/src/lib/lapack/dgelsx.f
@@ -0,0 +1,349 @@
+      SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DGELSY.
+*
+*  DGELSX computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize || A * X - B ||
+*  using a complete orthogonal factorization of A.  A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The routine first computes a QR factorization with column pivoting:
+*      A * P = Q * [ R11 R12 ]
+*                  [  0  R22 ]
+*  with R11 defined as the largest leading submatrix whose estimated
+*  condition number is less than 1/RCOND.  The order of R11, RANK,
+*  is the effective rank of A.
+*
+*  Then, R22 is considered to be negligible, and R12 is annihilated
+*  by orthogonal transformations from the right, arriving at the
+*  complete orthogonal factorization:
+*     A * P = Q * [ T11 0 ] * Z
+*                 [  0  0 ]
+*  The minimum-norm solution is then
+*     X = P * Z' [ inv(T11)*Q1'*B ]
+*                [        0       ]
+*  where Q1 consists of the first RANK columns of Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of
+*          columns of matrices B and X. NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been overwritten by details of its
+*          complete orthogonal factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the M-by-NRHS right hand side matrix B.
+*          On exit, the N-by-NRHS solution matrix X.
+*          If m >= n and RANK = n, the residual sum-of-squares for
+*          the solution in the i-th column is given by the sum of
+*          squares of elements N+1:M in that column.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,M,N).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an
+*          initial column, otherwise it is a free column.  Before
+*          the QR factorization of A, all initial columns are
+*          permuted to the leading positions; only the remaining
+*          free columns are moved as a result of column pivoting
+*          during the factorization.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  RCOND   (input) DOUBLE PRECISION
+*          RCOND is used to determine the effective rank of A, which
+*          is defined as the order of the largest leading triangular
+*          submatrix R11 in the QR factorization with pivoting of A,
+*          whose estimated condition number < 1/RCOND.
+*
+*  RANK    (output) INTEGER
+*          The effective rank of A, i.e., the order of the submatrix
+*          R11.  This is the same as the order of the submatrix T11
+*          in the complete orthogonal factorization of A.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                      (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IMAX, IMIN
+      PARAMETER          ( IMAX = 1, IMIN = 2 )
+      DOUBLE PRECISION   ZERO, ONE, DONE, NTDONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
+     $                   NTDONE = ONE )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+     $                   SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R,
+     $                   DTRSM, DTZRQF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M, N )
+      ISMIN = MN + 1
+      ISMAX = 2*MN + 1
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELSX', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max elements outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RANK = 0
+         GO TO 100
+      END IF
+*
+      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     Compute QR factorization with column pivoting of A:
+*        A * P = Q * R
+*
+      CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
+*
+*     workspace 3*N. Details of Householder rotations stored
+*     in WORK(1:MN).
+*
+*     Determine RANK using incremental condition estimation
+*
+      WORK( ISMIN ) = ONE
+      WORK( ISMAX ) = ONE
+      SMAX = ABS( A( 1, 1 ) )
+      SMIN = SMAX
+      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+         RANK = 0
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         GO TO 100
+      ELSE
+         RANK = 1
+      END IF
+*
+   10 CONTINUE
+      IF( RANK.LT.MN ) THEN
+         I = RANK + 1
+         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+     $                A( I, I ), SMAXPR, S2, C2 )
+*
+         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+            DO 20 I = 1, RANK
+               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+   20       CONTINUE
+            WORK( ISMIN+RANK ) = C1
+            WORK( ISMAX+RANK ) = C2
+            SMIN = SMINPR
+            SMAX = SMAXPR
+            RANK = RANK + 1
+            GO TO 10
+         END IF
+      END IF
+*
+*     Logically partition R = [ R11 R12 ]
+*                             [  0  R22 ]
+*     where R11 = R(1:RANK,1:RANK)
+*
+*     [R11,R12] = [ T11, 0 ] * Y
+*
+      IF( RANK.LT.N )
+     $   CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
+*
+*     Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+      CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+     $             B, LDB, WORK( 2*MN+1 ), INFO )
+*
+*     workspace NRHS
+*
+*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, ONE, A, LDA, B, LDB )
+*
+      DO 40 I = RANK + 1, N
+         DO 30 J = 1, NRHS
+            B( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+*
+*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+      IF( RANK.LT.N ) THEN
+         DO 50 I = 1, RANK
+            CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
+     $                   WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
+     $                   WORK( 2*MN+1 ) )
+   50    CONTINUE
+      END IF
+*
+*     workspace NRHS
+*
+*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+      DO 90 J = 1, NRHS
+         DO 60 I = 1, N
+            WORK( 2*MN+I ) = NTDONE
+   60    CONTINUE
+         DO 80 I = 1, N
+            IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
+               IF( JPVT( I ).NE.I ) THEN
+                  K = I
+                  T1 = B( K, J )
+                  T2 = B( JPVT( K ), J )
+   70             CONTINUE
+                  B( JPVT( K ), J ) = T1
+                  WORK( 2*MN+K ) = DONE
+                  T1 = T2
+                  K = JPVT( K )
+                  T2 = B( JPVT( K ), J )
+                  IF( JPVT( K ).NE.I )
+     $               GO TO 70
+                  B( I, J ) = T1
+                  WORK( 2*MN+K ) = DONE
+               END IF
+            END IF
+   80    CONTINUE
+   90 CONTINUE
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+  100 CONTINUE
+*
+      RETURN
+*
+*     End of DGELSX
+*
+      END
diff --git a/src/lib/lapack/dgelsy.f b/src/lib/lapack/dgelsy.f
new file mode 100644
index 00000000..4334650f
--- /dev/null
+++ b/src/lib/lapack/dgelsy.f
@@ -0,0 +1,391 @@
+      SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGELSY computes the minimum-norm solution to a real linear least
+*  squares problem:
+*      minimize || A * X - B ||
+*  using a complete orthogonal factorization of A.  A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The routine first computes a QR factorization with column pivoting:
+*      A * P = Q * [ R11 R12 ]
+*                  [  0  R22 ]
+*  with R11 defined as the largest leading submatrix whose estimated
+*  condition number is less than 1/RCOND.  The order of R11, RANK,
+*  is the effective rank of A.
+*
+*  Then, R22 is considered to be negligible, and R12 is annihilated
+*  by orthogonal transformations from the right, arriving at the
+*  complete orthogonal factorization:
+*     A * P = Q * [ T11 0 ] * Z
+*                 [  0  0 ]
+*  The minimum-norm solution is then
+*     X = P * Z' [ inv(T11)*Q1'*B ]
+*                [        0       ]
+*  where Q1 consists of the first RANK columns of Q.
+*
+*  This routine is basically identical to the original xGELSX except
+*  three differences:
+*    o The call to the subroutine xGEQPF has been substituted by the
+*      the call to the subroutine xGEQP3. This subroutine is a Blas-3
+*      version of the QR factorization with column pivoting.
+*    o Matrix B (the right hand side) is updated with Blas-3.
+*    o The permutation of matrix B (the right hand side) is faster and
+*      more simple.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of
+*          columns of matrices B and X. NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been overwritten by details of its
+*          complete orthogonal factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the M-by-NRHS right hand side matrix B.
+*          On exit, the N-by-NRHS solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,M,N).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of AP, otherwise column i is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of AP
+*          was the k-th column of A.
+*
+*  RCOND   (input) DOUBLE PRECISION
+*          RCOND is used to determine the effective rank of A, which
+*          is defined as the order of the largest leading triangular
+*          submatrix R11 in the QR factorization with pivoting of A,
+*          whose estimated condition number < 1/RCOND.
+*
+*  RANK    (output) INTEGER
+*          The effective rank of A, i.e., the order of the submatrix
+*          R11.  This is the same as the order of the submatrix T11
+*          in the complete orthogonal factorization of A.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          The unblocked strategy requires that:
+*             LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
+*          where MN = min( M, N ).
+*          The block algorithm requires that:
+*             LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
+*          where NB is an upper bound on the blocksize returned
+*          by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
+*          and DORMRZ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: If INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IMAX, IMIN
+      PARAMETER          ( IMAX = 1, IMIN = 2 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
+     $                   LWKOPT, MN, NB, NB1, NB2, NB3, NB4
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+     $                   SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET,
+     $                   DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M, N )
+      ISMIN = MN + 1
+      ISMAX = 2*MN + 1
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+         INFO = -7
+      END IF
+*
+*     Figure out optimal block size
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+            LWKMIN = 1
+            LWKOPT = 1
+         ELSE
+            NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+            NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+            NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
+            NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
+            NB = MAX( NB1, NB2, NB3, NB4 )
+            LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
+            LWKOPT = MAX( LWKMIN,
+     $                    MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGELSY', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+      BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     Compute QR factorization with column pivoting of A:
+*        A * P = Q * R
+*
+      CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+     $             LWORK-MN, INFO )
+      WSIZE = MN + WORK( MN+1 )
+*
+*     workspace: MN+2*N+NB*(N+1).
+*     Details of Householder rotations stored in WORK(1:MN).
+*
+*     Determine RANK using incremental condition estimation
+*
+      WORK( ISMIN ) = ONE
+      WORK( ISMAX ) = ONE
+      SMAX = ABS( A( 1, 1 ) )
+      SMIN = SMAX
+      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+         RANK = 0
+         CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+         GO TO 70
+      ELSE
+         RANK = 1
+      END IF
+*
+   10 CONTINUE
+      IF( RANK.LT.MN ) THEN
+         I = RANK + 1
+         CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+     $                A( I, I ), SMAXPR, S2, C2 )
+*
+         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+            DO 20 I = 1, RANK
+               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+   20       CONTINUE
+            WORK( ISMIN+RANK ) = C1
+            WORK( ISMAX+RANK ) = C2
+            SMIN = SMINPR
+            SMAX = SMAXPR
+            RANK = RANK + 1
+            GO TO 10
+         END IF
+      END IF
+*
+*     workspace: 3*MN.
+*
+*     Logically partition R = [ R11 R12 ]
+*                             [  0  R22 ]
+*     where R11 = R(1:RANK,1:RANK)
+*
+*     [R11,R12] = [ T11, 0 ] * Y
+*
+      IF( RANK.LT.N )
+     $   CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
+     $                LWORK-2*MN, INFO )
+*
+*     workspace: 2*MN.
+*     Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+      CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+     $             B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+      WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
+*
+*     workspace: 2*MN+NB*NRHS.
+*
+*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, ONE, A, LDA, B, LDB )
+*
+      DO 40 J = 1, NRHS
+         DO 30 I = RANK + 1, N
+            B( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+*
+*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+      IF( RANK.LT.N ) THEN
+         CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
+     $                LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
+     $                LWORK-2*MN, INFO )
+      END IF
+*
+*     workspace: 2*MN+NRHS.
+*
+*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+      DO 60 J = 1, NRHS
+         DO 50 I = 1, N
+            WORK( JPVT( I ) ) = B( I, J )
+   50    CONTINUE
+         CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+   60 CONTINUE
+*
+*     workspace: N.
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DGELSY
+*
+      END
diff --git a/src/lib/lapack/dgeql2.f b/src/lib/lapack/dgeql2.f
new file mode 100644
index 00000000..aa45113c
--- /dev/null
+++ b/src/lib/lapack/dgeql2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQL2 computes a QL factorization of a real m by n matrix A:
+*  A = Q * L.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, if m >= n, the lower triangle of the subarray
+*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
+*          if m <= n, the elements on and below the (n-m)-th
+*          superdiagonal contain the m by n lower trapezoidal matrix L;
+*          the remaining elements, with the array TAU, represent the
+*          orthogonal matrix Q as a product of elementary reflectors
+*          (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQL2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = K, 1, -1
+*
+*        Generate elementary reflector H(i) to annihilate
+*        A(1:m-k+i-1,n-k+i)
+*
+         CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
+     $                TAU( I ) )
+*
+*        Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
+*
+         AII = A( M-K+I, N-K+I )
+         A( M-K+I, N-K+I ) = ONE
+         CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
+     $               A, LDA, WORK )
+         A( M-K+I, N-K+I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DGEQL2
+*
+      END
diff --git a/src/lib/lapack/dgeqlf.f b/src/lib/lapack/dgeqlf.f
new file mode 100644
index 00000000..ec293574
--- /dev/null
+++ b/src/lib/lapack/dgeqlf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQLF computes a QL factorization of a real M-by-N matrix A:
+*  A = Q * L.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if m >= n, the lower triangle of the subarray
+*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
+*          if m <= n, the elements on and below the (n-m)-th
+*          superdiagonal contain the M-by-N lower trapezoidal matrix L;
+*          the remaining elements, with the array TAU, represent the
+*          orthogonal matrix Q as a product of elementary reflectors
+*          (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+     $                   MU, NB, NBMIN, NU, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQL2, DLARFB, DLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         K = MIN( M, N )
+         IF( K.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+            INFO = -7
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQLF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 1
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially.
+*        The last kk columns are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the QL factorization of the current block
+*           A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
+*
+            CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
+     $                   WORK, IINFO )
+            IF( N-K+I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+     $                      A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+               CALL DLARFB( 'Left', 'Transpose', 'Backward',
+     $                      'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+     $                      A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+         MU = M - K + I + NB - 1
+         NU = N - K + I + NB - 1
+      ELSE
+         MU = M
+         NU = N
+      END IF
+*
+*     Use unblocked code to factor the last or only block
+*
+      IF( MU.GT.0 .AND. NU.GT.0 )
+     $   CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGEQLF
+*
+      END
diff --git a/src/lib/lapack/dgeqp3.f b/src/lib/lapack/dgeqp3.f
new file mode 100644
index 00000000..d6bc537d
--- /dev/null
+++ b/src/lib/lapack/dgeqp3.f
@@ -0,0 +1,287 @@
+      SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQP3 computes a QR factorization with column pivoting of a
+*  matrix A:  A*P = Q*R  using Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of the array contains the
+*          min(M,N)-by-N upper trapezoidal matrix R; the elements below
+*          the diagonal, together with the array TAU, represent the
+*          orthogonal matrix Q as a product of min(M,N) elementary
+*          reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(J)=0,
+*          the J-th column of A is a free column.
+*          On exit, if JPVT(J)=K, then the J-th column of A*P was the
+*          the K-th column of A.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= 3*N+1.
+*          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit.
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real/complex scalar, and v is a real/complex vector
+*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
+*  A(i+1:m,i), and tau in TAU(i).
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            INB, INBMIN, IXOVER
+      PARAMETER          ( INB = 1, INBMIN = 2, IXOVER = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
+     $                   NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DNRM2
+      EXTERNAL           ILAENV, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test input arguments
+*     ====================
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         MINMN = MIN( M, N )
+         IF( MINMN.EQ.0 ) THEN
+            IWS = 1
+            LWKOPT = 1
+         ELSE
+            IWS = 3*N + 1
+            NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 )
+            LWKOPT = 2*N + ( N + 1 )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQP3', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( MINMN.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Move initial columns up front.
+*
+      NFXD = 1
+      DO 10 J = 1, N
+         IF( JPVT( J ).NE.0 ) THEN
+            IF( J.NE.NFXD ) THEN
+               CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
+               JPVT( J ) = JPVT( NFXD )
+               JPVT( NFXD ) = J
+            ELSE
+               JPVT( J ) = J
+            END IF
+            NFXD = NFXD + 1
+         ELSE
+            JPVT( J ) = J
+         END IF
+   10 CONTINUE
+      NFXD = NFXD - 1
+*
+*     Factorize fixed columns
+*     =======================
+*
+*     Compute the QR factorization of fixed columns and update
+*     remaining columns.
+*
+      IF( NFXD.GT.0 ) THEN
+         NA = MIN( M, NFXD )
+*CC      CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+         CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+         IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         IF( NA.LT.N ) THEN
+*CC         CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
+*CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
+            CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU,
+     $                   A( 1, NA+1 ), LDA, WORK, LWORK, INFO )
+            IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         END IF
+      END IF
+*
+*     Factorize free columns
+*     ======================
+*
+      IF( NFXD.LT.MINMN ) THEN
+*
+         SM = M - NFXD
+         SN = N - NFXD
+         SMINMN = MINMN - NFXD
+*
+*        Determine the block size.
+*
+         NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 )
+         NBMIN = 2
+         NX = 0
+*
+         IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
+*
+*           Determine when to cross over from blocked to unblocked code.
+*
+            NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1,
+     $           -1 ) )
+*
+*
+            IF( NX.LT.SMINMN ) THEN
+*
+*              Determine if workspace is large enough for blocked code.
+*
+               MINWS = 2*SN + ( SN+1 )*NB
+               IWS = MAX( IWS, MINWS )
+               IF( LWORK.LT.MINWS ) THEN
+*
+*                 Not enough workspace to use optimal NB: Reduce NB and
+*                 determine the minimum value of NB.
+*
+                  NB = ( LWORK-2*SN ) / ( SN+1 )
+                  NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN,
+     $                    -1, -1 ) )
+*
+*
+               END IF
+            END IF
+         END IF
+*
+*        Initialize partial column norms. The first N elements of work
+*        store the exact column norms.
+*
+         DO 20 J = NFXD + 1, N
+            WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 )
+            WORK( N+J ) = WORK( J )
+   20    CONTINUE
+*
+         IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
+     $       ( NX.LT.SMINMN ) ) THEN
+*
+*           Use blocked code initially.
+*
+            J = NFXD + 1
+*
+*           Compute factorization: while loop.
+*
+*
+            TOPBMN = MINMN - NX
+   30       CONTINUE
+            IF( J.LE.TOPBMN ) THEN
+               JB = MIN( NB, TOPBMN-J+1 )
+*
+*              Factorize JB columns among columns J:N.
+*
+               CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
+     $                      JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ),
+     $                      WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 )
+*
+               J = J + FJB
+               GO TO 30
+            END IF
+         ELSE
+            J = NFXD + 1
+         END IF
+*
+*        Use unblocked code to factor the last or only block.
+*
+*
+         IF( J.LE.MINMN )
+     $      CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
+     $                   TAU( J ), WORK( J ), WORK( N+J ),
+     $                   WORK( 2*N+1 ) )
+*
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGEQP3
+*
+      END
diff --git a/src/lib/lapack/dgeqpf.f b/src/lib/lapack/dgeqpf.f
new file mode 100644
index 00000000..1b7acd6d
--- /dev/null
+++ b/src/lib/lapack/dgeqpf.f
@@ -0,0 +1,231 @@
+      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
+*
+*  -- LAPACK deprecated driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DGEQP3.
+*
+*  DGEQPF computes a QR factorization with column pivoting of a
+*  real M-by-N matrix A: A*P = Q*R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of the array contains the
+*          min(M,N)-by-N upper triangular matrix R; the elements
+*          below the diagonal, together with the array TAU,
+*          represent the orthogonal matrix Q as a product of
+*          min(m,n) elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(i) = 0,
+*          the i-th column of A is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(n)
+*
+*  Each H(i) has the form
+*
+*     H = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
+*
+*  The matrix P is represented in jpvt as follows: If
+*     jpvt(j) = i
+*  then the jth column of P is the ith canonical unit vector.
+*
+*  Partial column norm updating strategy modified by
+*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+*    University of Zagreb, Croatia.
+*    June 2006.
+*  For more details see LAPACK Working Note 176.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MA, MN, PVT
+      DOUBLE PRECISION   AII, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQPF', -INFO )
+         RETURN
+      END IF
+*
+      MN = MIN( M, N )
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Move initial columns up front
+*
+      ITEMP = 1
+      DO 10 I = 1, N
+         IF( JPVT( I ).NE.0 ) THEN
+            IF( I.NE.ITEMP ) THEN
+               CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+               JPVT( I ) = JPVT( ITEMP )
+               JPVT( ITEMP ) = I
+            ELSE
+               JPVT( I ) = I
+            END IF
+            ITEMP = ITEMP + 1
+         ELSE
+            JPVT( I ) = I
+         END IF
+   10 CONTINUE
+      ITEMP = ITEMP - 1
+*
+*     Compute the QR factorization and update remaining columns
+*
+      IF( ITEMP.GT.0 ) THEN
+         MA = MIN( ITEMP, M )
+         CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
+     $                   A( 1, MA+1 ), LDA, WORK, INFO )
+         END IF
+      END IF
+*
+      IF( ITEMP.LT.MN ) THEN
+*
+*        Initialize partial column norms. The first n elements of
+*        work store the exact column norms.
+*
+         DO 20 I = ITEMP + 1, N
+            WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+            WORK( N+I ) = WORK( I )
+   20    CONTINUE
+*
+*        Compute factorization
+*
+         DO 40 I = ITEMP + 1, MN
+*
+*           Determine ith pivot column and swap if necessary
+*
+            PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+               ITEMP = JPVT( PVT )
+               JPVT( PVT ) = JPVT( I )
+               JPVT( I ) = ITEMP
+               WORK( PVT ) = WORK( I )
+               WORK( N+PVT ) = WORK( N+I )
+            END IF
+*
+*           Generate elementary reflector H(i)
+*
+            IF( I.LT.M ) THEN
+               CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+            ELSE
+               CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
+            END IF
+*
+            IF( I.LT.N ) THEN
+*
+*              Apply H(i) to A(i:m,i+1:n) from the left
+*
+               AII = A( I, I )
+               A( I, I ) = ONE
+               CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                     A( I, I+1 ), LDA, WORK( 2*N+1 ) )
+               A( I, I ) = AII
+            END IF
+*
+*           Update partial column norms
+*
+            DO 30 J = I + 1, N
+               IF( WORK( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following 4 lines follow from the analysis in
+*                 Lapack Working Note 176.
+*                 
+                  TEMP = ABS( A( I, J ) ) / WORK( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN 
+                     IF( M-I.GT.0 ) THEN
+                        WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )
+                        WORK( N+J ) = WORK( J )
+                     ELSE
+                        WORK( J ) = ZERO
+                        WORK( N+J ) = ZERO
+                     END IF
+                  ELSE
+                     WORK( J ) = WORK( J )*SQRT( TEMP )
+                  END IF
+               END IF
+   30       CONTINUE
+*
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DGEQPF
+*
+      END
diff --git a/src/lib/lapack/dgeqr2.f b/src/lib/lapack/dgeqr2.f
new file mode 100644
index 00000000..9872a162
--- /dev/null
+++ b/src/lib/lapack/dgeqr2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQR2 computes a QR factorization of a real m by n matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(m,n) by n upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQR2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+         CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                TAU( I ) )
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i) to A(i:m,i+1:n) from the left
+*
+            AII = A( I, I )
+            A( I, I ) = ONE
+            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                  A( I, I+1 ), LDA, WORK )
+            A( I, I ) = AII
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of DGEQR2
+*
+      END
diff --git a/src/lib/lapack/dgeqrf.f b/src/lib/lapack/dgeqrf.f
new file mode 100644
index 00000000..1e940597
--- /dev/null
+++ b/src/lib/lapack/dgeqrf.f
@@ -0,0 +1,196 @@
+      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEQRF computes a QR factorization of a real M-by-N matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the orthogonal matrix Q as a
+*          product of min(m,n) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQR2, DLARFB, DLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGEQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially
+*
+         DO 10 I = 1, K - NX, NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the QR factorization of the current block
+*           A(i:m,i:i+ib-1)
+*
+            CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+            IF( I+IB.LE.N ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(i:m,i+ib:n) from the left
+*
+               CALL DLARFB( 'Left', 'Transpose', 'Forward',
+     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
+     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+     $                      LDA, WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K )
+     $   CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGEQRF
+*
+      END
diff --git a/src/lib/lapack/dgerfs.f b/src/lib/lapack/dgerfs.f
new file mode 100644
index 00000000..bada6e56
--- /dev/null
+++ b/src/lib/lapack/dgerfs.f
@@ -0,0 +1,336 @@
+      SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+     $                   X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGERFS improves the computed solution to a system of linear
+*  equations and provides error bounds and backward error estimates for
+*  the solution.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form of the system of equations:
+*          = 'N':  A * X = B     (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The original N-by-N matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by DGETRF.
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          The right hand side matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          On entry, the solution matrix X, as computed by DGETRS.
+*          On exit, the improved solution matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The estimated forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).  The estimate is as reliable as
+*          the estimate for RCOND, and is almost always a slight
+*          overestimate of the true error.
+*
+*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The componentwise relative backward error of each solution
+*          vector X(j) (i.e., the smallest relative change in
+*          any element of A or B that makes X(j) an exact solution).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Internal Parameters
+*  ===================
+*
+*  ITMAX is the maximum number of steps of iterative refinement.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D+0 )
+      DOUBLE PRECISION   THREE
+      PARAMETER          ( THREE = 3.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      CHARACTER          TRANST
+      INTEGER            COUNT, I, J, K, KASE, NZ
+      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+         INFO = -12
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGERFS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+         DO 10 J = 1, NRHS
+            FERR( J ) = ZERO
+            BERR( J ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+*     NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+      NZ = N + 1
+      EPS = DLAMCH( 'Epsilon' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SAFE1 = NZ*SAFMIN
+      SAFE2 = SAFE1 / EPS
+*
+*     Do for each right hand side
+*
+      DO 140 J = 1, NRHS
+*
+         COUNT = 1
+         LSTRES = THREE
+   20    CONTINUE
+*
+*        Loop until stopping criterion is satisfied.
+*
+*        Compute residual R = B - op(A) * X,
+*        where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+         CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+         CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+     $               WORK( N+1 ), 1 )
+*
+*        Compute componentwise relative backward error from formula
+*
+*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+*        where abs(Z) is the componentwise absolute value of the matrix
+*        or vector Z.  If the i-th component of the denominator is less
+*        than SAFE2, then SAFE1 is added to the i-th components of the
+*        numerator and denominator before dividing.
+*
+         DO 30 I = 1, N
+            WORK( I ) = ABS( B( I, J ) )
+   30    CONTINUE
+*
+*        Compute abs(op(A))*abs(X) + abs(B).
+*
+         IF( NOTRAN ) THEN
+            DO 50 K = 1, N
+               XK = ABS( X( K, J ) )
+               DO 40 I = 1, N
+                  WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+   40          CONTINUE
+   50       CONTINUE
+         ELSE
+            DO 70 K = 1, N
+               S = ZERO
+               DO 60 I = 1, N
+                  S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+   60          CONTINUE
+               WORK( K ) = WORK( K ) + S
+   70       CONTINUE
+         END IF
+         S = ZERO
+         DO 80 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+            ELSE
+               S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+     $             ( WORK( I )+SAFE1 ) )
+            END IF
+   80    CONTINUE
+         BERR( J ) = S
+*
+*        Test stopping criterion. Continue iterating if
+*           1) The residual BERR(J) is larger than machine epsilon, and
+*           2) BERR(J) decreased by at least a factor of 2 during the
+*              last iteration, and
+*           3) At most ITMAX iterations tried.
+*
+         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+     $       COUNT.LE.ITMAX ) THEN
+*
+*           Update solution and try again.
+*
+            CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                   INFO )
+            CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+            LSTRES = BERR( J )
+            COUNT = COUNT + 1
+            GO TO 20
+         END IF
+*
+*        Bound error from formula
+*
+*        norm(X - XTRUE) / norm(X) .le. FERR =
+*        norm( abs(inv(op(A)))*
+*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+*        where
+*          norm(Z) is the magnitude of the largest component of Z
+*          inv(op(A)) is the inverse of op(A)
+*          abs(Z) is the componentwise absolute value of the matrix or
+*             vector Z
+*          NZ is the maximum number of nonzeros in any row of A, plus 1
+*          EPS is machine epsilon
+*
+*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+*        is incremented by SAFE1 if the i-th component of
+*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+*        Use DLACN2 to estimate the infinity-norm of the matrix
+*           inv(op(A)) * diag(W),
+*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+         DO 90 I = 1, N
+            IF( WORK( I ).GT.SAFE2 ) THEN
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+            ELSE
+               WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+            END IF
+   90    CONTINUE
+*
+         KASE = 0
+  100    CONTINUE
+         CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+     $                KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Multiply by diag(W)*inv(op(A)**T).
+*
+               CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
+     $                      N, INFO )
+               DO 110 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  110          CONTINUE
+            ELSE
+*
+*              Multiply by inv(op(A))*diag(W).
+*
+               DO 120 I = 1, N
+                  WORK( N+I ) = WORK( I )*WORK( N+I )
+  120          CONTINUE
+               CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+     $                      INFO )
+            END IF
+            GO TO 100
+         END IF
+*
+*        Normalize error.
+*
+         LSTRES = ZERO
+         DO 130 I = 1, N
+            LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+  130    CONTINUE
+         IF( LSTRES.NE.ZERO )
+     $      FERR( J ) = FERR( J ) / LSTRES
+*
+  140 CONTINUE
+*
+      RETURN
+*
+*     End of DGERFS
+*
+      END
diff --git a/src/lib/lapack/dgerq2.f b/src/lib/lapack/dgerq2.f
new file mode 100644
index 00000000..4dfe8b0f
--- /dev/null
+++ b/src/lib/lapack/dgerq2.f
@@ -0,0 +1,122 @@
+      SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGERQ2 computes an RQ factorization of a real m by n matrix A:
+*  A = R * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, if m <= n, the upper triangle of the subarray
+*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
+*          if m >= n, the elements on and above the (m-n)-th subdiagonal
+*          contain the m by n upper trapezoidal matrix R; the remaining
+*          elements, with the array TAU, represent the orthogonal matrix
+*          Q as a product of elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGERQ2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = K, 1, -1
+*
+*        Generate elementary reflector H(i) to annihilate
+*        A(m-k+i,1:n-k+i-1)
+*
+         CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
+     $                TAU( I ) )
+*
+*        Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
+*
+         AII = A( M-K+I, N-K+I )
+         A( M-K+I, N-K+I ) = ONE
+         CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+     $               TAU( I ), A, LDA, WORK )
+         A( M-K+I, N-K+I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DGERQ2
+*
+      END
diff --git a/src/lib/lapack/dgerqf.f b/src/lib/lapack/dgerqf.f
new file mode 100644
index 00000000..3dc22652
--- /dev/null
+++ b/src/lib/lapack/dgerqf.f
@@ -0,0 +1,213 @@
+      SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGERQF computes an RQ factorization of a real M-by-N matrix A:
+*  A = R * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if m <= n, the upper triangle of the subarray
+*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
+*          if m >= n, the elements on and above the (m-n)-th subdiagonal
+*          contain the M-by-N upper trapezoidal matrix R;
+*          the remaining elements, with the array TAU, represent the
+*          orthogonal matrix Q as a product of min(m,n) elementary
+*          reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+     $                   MU, NB, NBMIN, NU, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGERQ2, DLARFB, DLARFT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         K = MIN( M, N )
+         IF( K.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+            LWKOPT = M*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+            INFO = -7
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGERQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( K.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 1
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially.
+*        The last kk rows are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+         DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the RQ factorization of the current block
+*           A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
+*
+            CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
+     $                   WORK, IINFO )
+            IF( M-K+I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+     $                      A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+               CALL DLARFB( 'Right', 'No transpose', 'Backward',
+     $                      'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
+     $                      A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+         MU = M - K + I + NB - 1
+         NU = N - K + I + NB - 1
+      ELSE
+         MU = M
+         NU = N
+      END IF
+*
+*     Use unblocked code to factor the last or only block
+*
+      IF( MU.GT.0 .AND. NU.GT.0 )
+     $   CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGERQF
+*
+      END
diff --git a/src/lib/lapack/dgesc2.f b/src/lib/lapack/dgesc2.f
new file mode 100644
index 00000000..1b0331f5
--- /dev/null
+++ b/src/lib/lapack/dgesc2.f
@@ -0,0 +1,132 @@
+      SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), RHS( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGESC2 solves a system of linear equations
+*
+*            A * X = scale* RHS
+*
+*  with a general N-by-N matrix A using the LU factorization with
+*  complete pivoting computed by DGETC2.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the  LU part of the factorization of the n-by-n
+*          matrix A computed by DGETC2:  A = P * L * U * Q
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1, N).
+*
+*  RHS     (input/output) DOUBLE PRECISION array, dimension (N).
+*          On entry, the right hand side vector b.
+*          On exit, the solution vector X.
+*
+*  IPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  SCALE    (output) DOUBLE PRECISION
+*           On exit, SCALE contains the scale factor. SCALE is chosen
+*           0 <= SCALE <= 1 to prevent owerflow in the solution.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, TWO
+      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   BIGNUM, EPS, SMLNUM, TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASWP, DSCAL
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           IDAMAX, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*      Set constant to control owerflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Apply permutations IPIV to RHS
+*
+      CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
+*
+*     Solve for L part
+*
+      DO 20 I = 1, N - 1
+         DO 10 J = I + 1, N
+            RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
+   10    CONTINUE
+   20 CONTINUE
+*
+*     Solve for U part
+*
+      SCALE = ONE
+*
+*     Check for scaling
+*
+      I = IDAMAX( N, RHS, 1 )
+      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+         TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
+         CALL DSCAL( N, TEMP, RHS( 1 ), 1 )
+         SCALE = SCALE*TEMP
+      END IF
+*
+      DO 40 I = N, 1, -1
+         TEMP = ONE / A( I, I )
+         RHS( I ) = RHS( I )*TEMP
+         DO 30 J = I + 1, N
+            RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
+   30    CONTINUE
+   40 CONTINUE
+*
+*     Apply permutations JPIV to the solution (RHS)
+*
+      CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+      RETURN
+*
+*     End of DGESC2
+*
+      END
diff --git a/src/lib/lapack/dgesv.f b/src/lib/lapack/dgesv.f
new file mode 100644
index 00000000..220ef56f
--- /dev/null
+++ b/src/lib/lapack/dgesv.f
@@ -0,0 +1,107 @@
+      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGESV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+*  The LU decomposition with partial pivoting and row interchanges is
+*  used to factor A as
+*     A = P * L * U,
+*  where P is a permutation matrix, L is unit lower triangular, and U is
+*  upper triangular.  The factored form of A is then used to solve the
+*  system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the N-by-N coefficient matrix A.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          The pivot indices that define the permutation matrix P;
+*          row i of the matrix was interchanged with row IPIV(i).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS matrix of right hand side matrix B.
+*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
+*                has been completed, but the factor U is exactly
+*                singular, so the solution could not be computed.
+*
+*  =====================================================================
+*
+*     .. External Subroutines ..
+      EXTERNAL           DGETRF, DGETRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGESV ', -INFO )
+         RETURN
+      END IF
+*
+*     Compute the LU factorization of A.
+*
+      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+     $                INFO )
+      END IF
+      RETURN
+*
+*     End of DGESV
+*
+      END
diff --git a/src/lib/lapack/dgesvd.f b/src/lib/lapack/dgesvd.f
new file mode 100644
index 00000000..0b62ca10
--- /dev/null
+++ b/src/lib/lapack/dgesvd.f
@@ -0,0 +1,3401 @@
+      SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBU, JOBVT
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), S( * ), U( LDU, * ),
+     $                   VT( LDVT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGESVD computes the singular value decomposition (SVD) of a real
+*  M-by-N matrix A, optionally computing the left and/or right singular
+*  vectors. The SVD is written
+*
+*       A = U * SIGMA * transpose(V)
+*
+*  where SIGMA is an M-by-N matrix which is zero except for its
+*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
+*  are the singular values of A; they are real and non-negative, and
+*  are returned in descending order.  The first min(m,n) columns of
+*  U and V are the left and right singular vectors of A.
+*
+*  Note that the routine returns V**T, not V.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U are returned in array U:
+*          = 'S':  the first min(m,n) columns of U (the left singular
+*                  vectors) are returned in the array U;
+*          = 'O':  the first min(m,n) columns of U (the left singular
+*                  vectors) are overwritten on the array A;
+*          = 'N':  no columns of U (no left singular vectors) are
+*                  computed.
+*
+*  JOBVT   (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix
+*          V**T:
+*          = 'A':  all N rows of V**T are returned in the array VT;
+*          = 'S':  the first min(m,n) rows of V**T (the right singular
+*                  vectors) are returned in the array VT;
+*          = 'O':  the first min(m,n) rows of V**T (the right singular
+*                  vectors) are overwritten on the array A;
+*          = 'N':  no rows of V**T (no right singular vectors) are
+*                  computed.
+*
+*          JOBVT and JOBU cannot both be 'O'.
+*
+*  M       (input) INTEGER
+*          The number of rows of the input matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the input matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if JOBU = 'O',  A is overwritten with the first min(m,n)
+*                          columns of U (the left singular vectors,
+*                          stored columnwise);
+*          if JOBVT = 'O', A is overwritten with the first min(m,n)
+*                          rows of V**T (the right singular vectors,
+*                          stored rowwise);
+*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
+*                          are destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
+*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
+*          If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
+*          if JOBU = 'S', U contains the first min(m,n) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBU = 'N' or 'O', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBU = 'S' or 'A', LDU >= M.
+*
+*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)
+*          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
+*          V**T;
+*          if JOBVT = 'S', VT contains the first min(m,n) rows of
+*          V**T (the right singular vectors, stored rowwise);
+*          if JOBVT = 'N' or 'O', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+*          if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
+*          superdiagonal elements of an upper bidiagonal matrix B
+*          whose diagonal is in S (not necessarily sorted). B
+*          satisfies A = U * B * VT, so it has the same singular values
+*          as A, and singular vectors related by U and VT.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if DBDSQR did not converge, INFO specifies how many
+*                superdiagonals of an intermediate bidiagonal form B
+*                did not converge to zero. See the description of WORK
+*                above for details.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
+     $                   WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
+      INTEGER            BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
+     $                   ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
+     $                   MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
+     $                   NRVT, WRKBL
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
+     $                   DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      WNTUA = LSAME( JOBU, 'A' )
+      WNTUS = LSAME( JOBU, 'S' )
+      WNTUAS = WNTUA .OR. WNTUS
+      WNTUO = LSAME( JOBU, 'O' )
+      WNTUN = LSAME( JOBU, 'N' )
+      WNTVA = LSAME( JOBVT, 'A' )
+      WNTVS = LSAME( JOBVT, 'S' )
+      WNTVAS = WNTVA .OR. WNTVS
+      WNTVO = LSAME( JOBVT, 'O' )
+      WNTVN = LSAME( JOBVT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
+     $         ( WNTVO .AND. WNTUO ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -6
+      ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
+         INFO = -9
+      ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
+         INFO = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         MINWRK = 1
+         MAXWRK = 1
+         IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+*           Compute space needed for DBDSQR
+*
+            MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+            BDSPAC = 5*N
+            IF( M.GE.MNTHR ) THEN
+               IF( WNTUN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBU='N')
+*
+                  MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*N+2*N*
+     $                     ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  IF( WNTVO .OR. WNTVAS )
+     $               MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+     $                        ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( MAXWRK, BDSPAC )
+                  MINWRK = MAX( 4*N, BDSPAC )
+               ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+*                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUS .AND. WNTVN ) THEN
+*
+*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUS .AND. WNTVO ) THEN
+*
+*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = 2*N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUS .AND. WNTVAS ) THEN
+*
+*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUA .AND. WNTVN ) THEN
+*
+*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUA .AND. WNTVO ) THEN
+*
+*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = 2*N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               ELSE IF( WNTUA .AND. WNTVAS ) THEN
+*
+*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+2*N*
+     $                    ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+N*
+     $                    ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = MAX( 3*N+M, BDSPAC )
+               END IF
+            ELSE
+*
+*              Path 10 (M at least N, but not much larger)
+*
+               MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTUS .OR. WNTUO )
+     $            MAXWRK = MAX( MAXWRK, 3*N+N*
+     $                     ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
+               IF( WNTUA )
+     $            MAXWRK = MAX( MAXWRK, 3*N+M*
+     $                     ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
+               IF( .NOT.WNTVN )
+     $            MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+     $                     ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, BDSPAC )
+               MINWRK = MAX( 3*N+M, BDSPAC )
+            END IF
+         ELSE IF( MINMN.GT.0 ) THEN
+*
+*           Compute space needed for DBDSQR
+*
+            MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+            BDSPAC = 5*M
+            IF( N.GE.MNTHR ) THEN
+               IF( WNTVN ) THEN
+*
+*                 Path 1t(N much larger than M, JOBVT='N')
+*
+                  MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 3*M+2*M*
+     $                     ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  IF( WNTUO .OR. WNTUAS )
+     $               MAXWRK = MAX( MAXWRK, 3*M+M*
+     $                        ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = MAX( MAXWRK, BDSPAC )
+                  MINWRK = MAX( 4*M, BDSPAC )
+               ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+*                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+*                 Path 3t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVS .AND. WNTUN ) THEN
+*
+*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVS .AND. WNTUO ) THEN
+*
+*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = 2*M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+*                 Path 6t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVA .AND. WNTUN ) THEN
+*
+*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVA .AND. WNTUO ) THEN
+*
+*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = 2*M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               ELSE IF( WNTVA .AND. WNTUAS ) THEN
+*
+*                 Path 9t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+2*M*
+     $                    ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+     $                    ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 3*M+M*
+     $                    ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, BDSPAC )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = MAX( 3*M+N, BDSPAC )
+               END IF
+            ELSE
+*
+*              Path 10t(N greater than M, but not much larger)
+*
+               MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTVS .OR. WNTVO )
+     $            MAXWRK = MAX( MAXWRK, 3*M+M*
+     $                     ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
+               IF( WNTVA )
+     $            MAXWRK = MAX( MAXWRK, 3*M+N*
+     $                     ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
+               IF( .NOT.WNTUN )
+     $            MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
+     $                     ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+               MAXWRK = MAX( MAXWRK, BDSPAC )
+               MINWRK = MAX( 3*M+N, BDSPAC )
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGESVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        A has at least as many rows as columns. If A has sufficiently
+*        more rows than columns, first reduce using the QR
+*        decomposition (if sufficient workspace available)
+*
+         IF( M.GE.MNTHR ) THEN
+*
+            IF( WNTUN ) THEN
+*
+*              Path 1 (M much larger than N, JOBU='N')
+*              No left singular vectors to be computed
+*
+               ITAU = 1
+               IWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (Workspace: need 2*N, prefer N+N*NB)
+*
+               CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+               IE = 1
+               ITAUQ = IE + N
+               ITAUP = ITAUQ + N
+               IWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+               CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                      IERR )
+               NCVT = 0
+               IF( WNTVO .OR. WNTVAS ) THEN
+*
+*                 If right singular vectors desired, generate P'.
+*                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                  CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  NCVT = N
+               END IF
+               IWORK = IE + N
+*
+*              Perform bidiagonal QR iteration, computing right
+*              singular vectors of A in A if desired
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
+     $                      DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+*              If right singular vectors desired in VT, copy them there
+*
+               IF( WNTVAS )
+     $            CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+            ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+*              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*              N left singular vectors to be overwritten on A and
+*              no right singular vectors to be computed
+*
+               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+*                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+*                    WORK(IU) is LDA by N, WORK(IR) is N by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = N
+                  ELSE
+*
+*                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
+*
+                     LDWRKU = ( LWORK-N*N-N ) / N
+                     LDWRKR = N
+                  END IF
+                  ITAU = IR + LDWRKR*N
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to WORK(IR) and zero out below it
+*
+                  CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+     $                         LDWRKR )
+*
+*                 Generate Q in A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + N
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in WORK(IR)
+*                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                  CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing R
+*                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUQ ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+                  IWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of R in WORK(IR)
+*                 (Workspace: need N*N+BDSPAC)
+*
+                  CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
+     $                         WORK( IR ), LDWRKR, DUM, 1,
+     $                         WORK( IWORK ), INFO )
+                  IU = IE + N
+*
+*                 Multiply Q in A by left singular vectors of R in
+*                 WORK(IR), storing result in WORK(IU) and copying to A
+*                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+                  DO 10 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   10             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  IE = 1
+                  ITAUQ = IE + N
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize A
+*                 (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing A
+*                 (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+                  CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in A
+*                 (Workspace: need BDSPAC)
+*
+                  CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
+     $                         A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+*              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = N
+                  ELSE
+*
+*                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
+*
+                     LDWRKU = ( LWORK-N*N-N ) / N
+                     LDWRKR = N
+                  END IF
+                  ITAU = IR + LDWRKR*N
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            VT( 2, 1 ), LDVT )
+*
+*                 Generate Q in A
+*                 (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + N
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in VT, copying result to WORK(IR)
+*                 (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                  CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
+*
+*                 Generate left vectors bidiagonalizing R in WORK(IR)
+*                 (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                  CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUQ ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing R in VT
+*                 (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
+*
+                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of R in WORK(IR) and computing right
+*                 singular vectors of R in VT
+*                 (Workspace: need N*N+BDSPAC)
+*
+                  CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
+     $                         WORK( IR ), LDWRKR, DUM, 1,
+     $                         WORK( IWORK ), INFO )
+                  IU = IE + N
+*
+*                 Multiply Q in A by left singular vectors of R in
+*                 WORK(IR), storing result in WORK(IU) and copying to A
+*                 (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+                  DO 20 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   20             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  ITAU = 1
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (Workspace: need 2*N, prefer N+N*NB)
+*
+                  CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            VT( 2, 1 ), LDVT )
+*
+*                 Generate Q in A
+*                 (Workspace: need 2*N, prefer N+N*NB)
+*
+                  CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + N
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in VT
+*                 (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                  CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Multiply Q in A by left vectors bidiagonalizing R
+*                 (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                  CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                         WORK( ITAUQ ), A, LDA, WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing R in VT
+*                 (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                  CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in A and computing right
+*                 singular vectors of A in VT
+*                 (Workspace: need BDSPAC)
+*
+                  CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
+     $                         A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTUS ) THEN
+*
+               IF( WNTVN ) THEN
+*
+*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*                 N left singular vectors to be computed in U and
+*                 no right singular vectors to be computed
+*
+                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IR) is LDA by N
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is N by N
+*
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IR+1 ), LDWRKR )
+*
+*                    Generate Q in A
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IR)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left vectors bidiagonalizing R in WORK(IR)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IR)
+*                    (Workspace: need N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+     $                            1, WORK( IR ), LDWRKR, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IR), storing result in U
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+     $                           WORK( IR ), LDWRKR, ZERO, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+     $                            LDA )
+*
+*                    Bidiagonalize R in A
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left vectors bidiagonalizing R
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+     $                            1, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVO ) THEN
+*
+*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*                 N left singular vectors to be computed in U and
+*                 N right singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     ELSE
+*
+*                       WORK(IU) is N by N and WORK(IR) is N by N
+*
+                        LDWRKU = N
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (Workspace: need 2*N*N+4*N,
+*                                prefer 2*N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need 2*N*N+4*N-1,
+*                                prefer 2*N*N+3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in WORK(IR)
+*                    (Workspace: need 2*N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+     $                            WORK( IR ), LDWRKR, WORK( IU ),
+     $                            LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IU), storing result in U
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+     $                           WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+*                    Copy right singular vectors of R to A
+*                    (Workspace: need N*N)
+*
+                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+     $                            LDA )
+*
+*                    Bidiagonalize R in A
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left vectors bidiagonalizing R
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right vectors bidiagonalizing R in A
+*                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in A
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+     $                            LDA, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVAS ) THEN
+*
+*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
+*                         or 'A')
+*                 N left singular vectors to be computed in U and
+*                 N right singular vectors to be computed in VT
+*
+                  IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is N by N
+*
+                        LDWRKU = N
+                     END IF
+                     ITAU = IU + LDWRKU*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to VT
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+     $                            LDVT )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (Workspace: need N*N+4*N-1,
+*                                prefer N*N+3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in VT
+*                    (Workspace: need N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+     $                            LDVT, WORK( IU ), LDWRKU, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IU), storing result in U
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+     $                           WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to VT, zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                               VT( 2, 1 ), LDVT )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in VT
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in VT
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               END IF
+*
+            ELSE IF( WNTUA ) THEN
+*
+               IF( WNTVN ) THEN
+*
+*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*                 M left singular vectors to be computed in U and
+*                 no right singular vectors to be computed
+*
+                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IR) is LDA by N
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is N by N
+*
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IR+1 ), LDWRKR )
+*
+*                    Generate Q in U
+*                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IR)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IR)
+*                    (Workspace: need N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+     $                            1, WORK( IR ), LDWRKR, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IR), storing result in A
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+     $                           WORK( IR ), LDWRKR, ZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+     $                            LDA )
+*
+*                    Bidiagonalize R in A
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in A
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+     $                            1, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVO ) THEN
+*
+*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*                 M left singular vectors to be computed in U and
+*                 N right singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     ELSE
+*
+*                       WORK(IU) is N by N and WORK(IR) is N by N
+*
+                        LDWRKU = N
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (Workspace: need 2*N*N+4*N,
+*                                prefer 2*N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need 2*N*N+4*N-1,
+*                                prefer 2*N*N+3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in WORK(IR)
+*                    (Workspace: need 2*N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+     $                            WORK( IR ), LDWRKR, WORK( IU ),
+     $                            LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IU), storing result in A
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+     $                           WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+*                    Copy right singular vectors of R from WORK(IR) to A
+*
+                     CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+     $                            LDA )
+*
+*                    Bidiagonalize R in A
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in A
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in A
+*                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in A
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+     $                            LDA, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVAS ) THEN
+*
+*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
+*                         or 'A')
+*                 M left singular vectors to be computed in U and
+*                 N right singular vectors to be computed in VT
+*
+                  IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is N by N
+*
+                        LDWRKU = N
+                     END IF
+                     ITAU = IU + LDWRKU*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to VT
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+     $                            LDVT )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+                     CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (Workspace: need N*N+4*N-1,
+*                                prefer N*N+3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in VT
+*                    (Workspace: need N*N+BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+     $                            LDVT, WORK( IU ), LDWRKU, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IU), storing result in A
+*                    (Workspace: need N*N)
+*
+                     CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+     $                           WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (Workspace: need 2*N, prefer N+N*NB)
+*
+                     CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (Workspace: need N+M, prefer N+M*NB)
+*
+                     CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R from A to VT, zeroing out below it
+*
+                     CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+     $                               VT( 2, 1 ), LDVT )
+                     IE = ITAU
+                     ITAUQ = IE + N
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in VT
+*                    (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+                     CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in VT
+*                    (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+                     CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+                     CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               END IF
+*
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR
+*
+*           Path 10 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*
+            IE = 1
+            ITAUQ = IE + N
+            ITAUP = ITAUQ + N
+            IWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                   IERR )
+            IF( WNTUAS ) THEN
+*
+*              If left singular vectors desired in U, copy result to U
+*              and generate left bidiagonalizing vectors in U
+*              (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
+*
+               CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+               IF( WNTUS )
+     $            NCU = N
+               IF( WNTUA )
+     $            NCU = M
+               CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVAS ) THEN
+*
+*              If right singular vectors desired in VT, copy result to
+*              VT and generate right bidiagonalizing vectors in VT
+*              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+               CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTUO ) THEN
+*
+*              If left singular vectors desired in A, generate left
+*              bidiagonalizing vectors in A
+*              (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+               CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVO ) THEN
+*
+*              If right singular vectors desired in A, generate right
+*              bidiagonalizing vectors in A
+*              (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+               CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IWORK = IE + N
+            IF( WNTUAS .OR. WNTUO )
+     $         NRU = M
+            IF( WNTUN )
+     $         NRU = 0
+            IF( WNTVAS .OR. WNTVO )
+     $         NCVT = N
+            IF( WNTVN )
+     $         NCVT = 0
+            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in VT
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+     $                      LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in A
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+     $                      U, LDU, DUM, 1, WORK( IWORK ), INFO )
+            ELSE
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in A and computing right singular
+*              vectors in VT
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+     $                      LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR ) THEN
+*
+            IF( WNTVN ) THEN
+*
+*              Path 1t(N much larger than M, JOBVT='N')
+*              No right singular vectors to be computed
+*
+               ITAU = 1
+               IWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (Workspace: need 2*M, prefer M+M*NB)
+*
+               CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+               IE = 1
+               ITAUQ = IE + M
+               ITAUP = ITAUQ + M
+               IWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+               CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                      IERR )
+               IF( WNTUO .OR. WNTUAS ) THEN
+*
+*                 If left singular vectors desired, generate Q
+*                 (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                  CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+               END IF
+               IWORK = IE + M
+               NRU = 0
+               IF( WNTUO .OR. WNTUAS )
+     $            NRU = M
+*
+*              Perform bidiagonal QR iteration, computing left singular
+*              vectors of A in A if desired
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
+     $                      LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+*              If left singular vectors desired in U, copy them there
+*
+               IF( WNTUAS )
+     $            CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+            ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+*              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*              M right singular vectors to be overwritten on A and
+*              no left singular vectors to be computed
+*
+               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = M
+                  ELSE
+*
+*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+                     LDWRKU = M
+                     CHUNK = ( LWORK-M*M-M ) / M
+                     LDWRKR = M
+                  END IF
+                  ITAU = IR + LDWRKR*M
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to WORK(IR) and zero out above it
+*
+                  CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                         WORK( IR+LDWRKR ), LDWRKR )
+*
+*                 Generate Q in A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + M
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in WORK(IR)
+*                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                  CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing L
+*                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUP ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+                  IWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing right
+*                 singular vectors of L in WORK(IR)
+*                 (Workspace: need M*M+BDSPAC)
+*
+                  CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+     $                         WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+     $                         WORK( IWORK ), INFO )
+                  IU = IE + M
+*
+*                 Multiply right singular vectors of L in WORK(IR) by Q
+*                 in A, storing result in WORK(IU) and copying to A
+*                 (Workspace: need M*M+2*M, prefer M*M+M*N+M)
+*
+                  DO 30 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+     $                            A( 1, I ), LDA )
+   30             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  IE = 1
+                  ITAUQ = IE + M
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize A
+*                 (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+                  CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing A
+*                 (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                  CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing right
+*                 singular vectors of A in A
+*                 (Workspace: need BDSPAC)
+*
+                  CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
+     $                         DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+*              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = M
+                  ELSE
+*
+*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+                     LDWRKU = M
+                     CHUNK = ( LWORK-M*M-M ) / M
+                     LDWRKR = M
+                  END IF
+                  ITAU = IR + LDWRKR*M
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing about above it
+*
+                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+     $                         LDU )
+*
+*                 Generate Q in A
+*                 (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + M
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in U, copying result to WORK(IR)
+*                 (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                  CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
+*
+*                 Generate right vectors bidiagonalizing L in WORK(IR)
+*                 (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+                  CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUP ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing L in U
+*                 (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of L in U, and computing right
+*                 singular vectors of L in WORK(IR)
+*                 (Workspace: need M*M+BDSPAC)
+*
+                  CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+     $                         WORK( IR ), LDWRKR, U, LDU, DUM, 1,
+     $                         WORK( IWORK ), INFO )
+                  IU = IE + M
+*
+*                 Multiply right singular vectors of L in WORK(IR) by Q
+*                 in A, storing result in WORK(IU) and copying to A
+*                 (Workspace: need M*M+2*M, prefer M*M+M*N+M))
+*
+                  DO 40 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, ZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+     $                            A( 1, I ), LDA )
+   40             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  ITAU = 1
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (Workspace: need 2*M, prefer M+M*NB)
+*
+                  CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing out above it
+*
+                  CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+     $                         LDU )
+*
+*                 Generate Q in A
+*                 (Workspace: need 2*M, prefer M+M*NB)
+*
+                  CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = ITAU
+                  ITAUQ = IE + M
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in U
+*                 (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                  CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Multiply right vectors bidiagonalizing L by Q in A
+*                 (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                  CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+     $                         WORK( ITAUP ), A, LDA, WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing L in U
+*                 (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                  CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in U and computing right
+*                 singular vectors of A in A
+*                 (Workspace: need BDSPAC)
+*
+                  CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
+     $                         U, LDU, DUM, 1, WORK( IWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTVS ) THEN
+*
+               IF( WNTUN ) THEN
+*
+*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 no left singular vectors to be computed
+*
+                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IR) is LDA by M
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is M by M
+*
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IR+LDWRKR ), LDWRKR )
+*
+*                    Generate Q in A
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IR)
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right vectors bidiagonalizing L in
+*                    WORK(IR)
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of L in WORK(IR)
+*                    (Workspace: need M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+     $                            WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IR) by
+*                    Q in A, storing result in VT
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+     $                           LDWRKR, A, LDA, ZERO, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy result to VT
+*
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+     $                            LDA )
+*
+*                    Bidiagonalize L in A
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right vectors bidiagonalizing L by Q in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+     $                            LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUO ) THEN
+*
+*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 M left singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     ELSE
+*
+*                       WORK(IU) is M by M and WORK(IR) is M by M
+*
+                        LDWRKU = M
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out below it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (Workspace: need 2*M*M+4*M,
+*                                prefer 2*M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need 2*M*M+4*M-1,
+*                                prefer 2*M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in WORK(IR) and computing
+*                    right singular vectors of L in WORK(IU)
+*                    (Workspace: need 2*M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+     $                            WORK( IU ), LDWRKU, WORK( IR ),
+     $                            LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in A, storing result in VT
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+     $                           LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+*                    Copy left singular vectors of L to A
+*                    (Workspace: need M*M)
+*
+                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+     $                            LDA )
+*
+*                    Bidiagonalize L in A
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right vectors bidiagonalizing L by Q in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors of L in A
+*                    (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, compute left
+*                    singular vectors of A in A and compute right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUAS ) THEN
+*
+*                 Path 6t(N much larger than M, JOBU='S' or 'A',
+*                         JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 M left singular vectors to be computed in U
+*
+                  IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is LDA by M
+*
+                        LDWRKU = M
+                     END IF
+                     ITAU = IU + LDWRKU*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to U
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+     $                            LDU )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need M*M+4*M-1,
+*                                prefer M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in U and computing right
+*                    singular vectors of L in WORK(IU)
+*                    (Workspace: need M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+     $                            WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in A, storing result in VT
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+     $                           LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+     $                            LDU )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in U
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in U by Q
+*                    in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               END IF
+*
+            ELSE IF( WNTVA ) THEN
+*
+               IF( WNTUN ) THEN
+*
+*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 no left singular vectors to be computed
+*
+                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IR) is LDA by M
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is M by M
+*
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IR+LDWRKR ), LDWRKR )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IR)
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need M*M+4*M-1,
+*                                prefer M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of L in WORK(IR)
+*                    (Workspace: need M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+     $                            WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IR) by
+*                    Q in VT, storing result in A
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+     $                           LDWRKR, VT, LDVT, ZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+     $                            LDA )
+*
+*                    Bidiagonalize L in A
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in A by Q
+*                    in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+     $                            LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUO ) THEN
+*
+*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 M left singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     ELSE
+*
+*                       WORK(IU) is M by M and WORK(IR) is M by M
+*
+                        LDWRKU = M
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (Workspace: need 2*M*M+4*M,
+*                                prefer 2*M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need 2*M*M+4*M-1,
+*                                prefer 2*M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in WORK(IR) and computing
+*                    right singular vectors of L in WORK(IU)
+*                    (Workspace: need 2*M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+     $                            WORK( IU ), LDWRKU, WORK( IR ),
+     $                            LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in VT, storing result in A
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+     $                           LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy left singular vectors of A from WORK(IR) to A
+*
+                     CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+     $                            LDA )
+*
+*                    Bidiagonalize L in A
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in A by Q
+*                    in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in A
+*                    (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in A and computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUAS ) THEN
+*
+*                 Path 9t(N much larger than M, JOBU='S' or 'A',
+*                         JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 M left singular vectors to be computed in U
+*
+                  IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is M by M
+*
+                        LDWRKU = M
+                     END IF
+                     ITAU = IU + LDWRKU*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to U
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            WORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+     $                            LDU )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+                     CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in U and computing right
+*                    singular vectors of L in WORK(IU)
+*                    (Workspace: need M*M+BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+     $                            WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+     $                            WORK( IWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in VT, storing result in A
+*                    (Workspace: need M*M)
+*
+                     CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+     $                           LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (Workspace: need 2*M, prefer M+M*NB)
+*
+                     CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (Workspace: need M+N, prefer M+N*NB)
+*
+                     CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+     $                            LDU )
+                     IE = ITAU
+                     ITAUQ = IE + M
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in U
+*                    (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+                     CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in U by Q
+*                    in VT
+*                    (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+                     CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+                     CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (Workspace: need BDSPAC)
+*
+                     CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+     $                            LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               END IF
+*
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR
+*
+*           Path 10t(N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*
+            IE = 1
+            ITAUQ = IE + M
+            ITAUP = ITAUQ + M
+            IWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+            CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                   IERR )
+            IF( WNTUAS ) THEN
+*
+*              If left singular vectors desired in U, copy result to U
+*              and generate left bidiagonalizing vectors in U
+*              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+               CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVAS ) THEN
+*
+*              If right singular vectors desired in VT, copy result to
+*              VT and generate right bidiagonalizing vectors in VT
+*              (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
+*
+               CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               IF( WNTVA )
+     $            NRVT = N
+               IF( WNTVS )
+     $            NRVT = M
+               CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTUO ) THEN
+*
+*              If left singular vectors desired in A, generate left
+*              bidiagonalizing vectors in A
+*              (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+               CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVO ) THEN
+*
+*              If right singular vectors desired in A, generate right
+*              bidiagonalizing vectors in A
+*              (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+               CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IWORK = IE + M
+            IF( WNTUAS .OR. WNTUO )
+     $         NRU = M
+            IF( WNTUN )
+     $         NRU = 0
+            IF( WNTVAS .OR. WNTVO )
+     $         NCVT = N
+            IF( WNTVN )
+     $         NCVT = 0
+            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in VT
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+     $                      LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in A
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+     $                      U, LDU, DUM, 1, WORK( IWORK ), INFO )
+            ELSE
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in A and computing right singular
+*              vectors in VT
+*              (Workspace: need BDSPAC)
+*
+               CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+     $                      LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     If DBDSQR failed to converge, copy unconverged superdiagonals
+*     to WORK( 2:MINMN )
+*
+      IF( INFO.NE.0 ) THEN
+         IF( IE.GT.2 ) THEN
+            DO 50 I = 1, MINMN - 1
+               WORK( I+1 ) = WORK( I+IE-1 )
+   50       CONTINUE
+         END IF
+         IF( IE.LT.2 ) THEN
+            DO 60 I = MINMN - 1, 1, -1
+               WORK( I+1 ) = WORK( I+IE-1 )
+   60       CONTINUE
+         END IF
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+     $                   MINMN, IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+     $                   MINMN, IERR )
+      END IF
+*
+*     Return optimal workspace in WORK(1)
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGESVD
+*
+      END
diff --git a/src/lib/lapack/dgesvx.f b/src/lib/lapack/dgesvx.f
new file mode 100644
index 00000000..0645a20c
--- /dev/null
+++ b/src/lib/lapack/dgesvx.f
@@ -0,0 +1,479 @@
+      SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
+     $                   EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
+     $                   WORK, IWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED, FACT, TRANS
+      INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+     $                   BERR( * ), C( * ), FERR( * ), R( * ),
+     $                   WORK( * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGESVX uses the LU factorization to compute the solution to a real
+*  system of linear equations
+*     A * X = B,
+*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+*  Error bounds on the solution and a condition estimate are also
+*  provided.
+*
+*  Description
+*  ===========
+*
+*  The following steps are performed:
+*
+*  1. If FACT = 'E', real scaling factors are computed to equilibrate
+*     the system:
+*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
+*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+*     Whether or not the system will be equilibrated depends on the
+*     scaling of the matrix A, but if equilibration is used, A is
+*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+*     or diag(C)*B (if TRANS = 'T' or 'C').
+*
+*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+*     matrix A (after equilibration if FACT = 'E') as
+*        A = P * L * U,
+*     where P is a permutation matrix, L is a unit lower triangular
+*     matrix, and U is upper triangular.
+*
+*  3. If some U(i,i)=0, so that U is exactly singular, then the routine
+*     returns with INFO = i. Otherwise, the factored form of A is used
+*     to estimate the condition number of the matrix A.  If the
+*     reciprocal of the condition number is less than machine precision,
+*     INFO = N+1 is returned as a warning, but the routine still goes on
+*     to solve for X and compute error bounds as described below.
+*
+*  4. The system of equations is solved for X using the factored form
+*     of A.
+*
+*  5. Iterative refinement is applied to improve the computed solution
+*     matrix and calculate error bounds and backward error estimates
+*     for it.
+*
+*  6. If equilibration was used, the matrix X is premultiplied by
+*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+*     that it solves the original system before equilibration.
+*
+*  Arguments
+*  =========
+*
+*  FACT    (input) CHARACTER*1
+*          Specifies whether or not the factored form of the matrix A is
+*          supplied on entry, and if not, whether the matrix A should be
+*          equilibrated before it is factored.
+*          = 'F':  On entry, AF and IPIV contain the factored form of A.
+*                  If EQUED is not 'N', the matrix A has been
+*                  equilibrated with scaling factors given by R and C.
+*                  A, AF, and IPIV are not modified.
+*          = 'N':  The matrix A will be copied to AF and factored.
+*          = 'E':  The matrix A will be equilibrated if necessary, then
+*                  copied to AF and factored.
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form of the system of equations:
+*          = 'N':  A * X = B     (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Transpose)
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrices B and X.  NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is
+*          not 'N', then A must have been equilibrated by the scaling
+*          factors in R and/or C.  A is not modified if FACT = 'F' or
+*          'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+*          On exit, if EQUED .ne. 'N', A is scaled as follows:
+*          EQUED = 'R':  A := diag(R) * A
+*          EQUED = 'C':  A := A * diag(C)
+*          EQUED = 'B':  A := diag(R) * A * diag(C).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
+*          If FACT = 'F', then AF is an input argument and on entry
+*          contains the factors L and U from the factorization
+*          A = P*L*U as computed by DGETRF.  If EQUED .ne. 'N', then
+*          AF is the factored form of the equilibrated matrix A.
+*
+*          If FACT = 'N', then AF is an output argument and on exit
+*          returns the factors L and U from the factorization A = P*L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then AF is an output argument and on exit
+*          returns the factors L and U from the factorization A = P*L*U
+*          of the equilibrated matrix A (see the description of A for
+*          the form of the equilibrated matrix).
+*
+*  LDAF    (input) INTEGER
+*          The leading dimension of the array AF.  LDAF >= max(1,N).
+*
+*  IPIV    (input or output) INTEGER array, dimension (N)
+*          If FACT = 'F', then IPIV is an input argument and on entry
+*          contains the pivot indices from the factorization A = P*L*U
+*          as computed by DGETRF; row i of the matrix was interchanged
+*          with row IPIV(i).
+*
+*          If FACT = 'N', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = P*L*U
+*          of the original matrix A.
+*
+*          If FACT = 'E', then IPIV is an output argument and on exit
+*          contains the pivot indices from the factorization A = P*L*U
+*          of the equilibrated matrix A.
+*
+*  EQUED   (input or output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration (always true if FACT = 'N').
+*          = 'R':  Row equilibration, i.e., A has been premultiplied by
+*                  diag(R).
+*          = 'C':  Column equilibration, i.e., A has been postmultiplied
+*                  by diag(C).
+*          = 'B':  Both row and column equilibration, i.e., A has been
+*                  replaced by diag(R) * A * diag(C).
+*          EQUED is an input argument if FACT = 'F'; otherwise, it is an
+*          output argument.
+*
+*  R       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The row scale factors for A.  If EQUED = 'R' or 'B', A is
+*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
+*          is not accessed.  R is an input argument if FACT = 'F';
+*          otherwise, R is an output argument.  If FACT = 'F' and
+*          EQUED = 'R' or 'B', each element of R must be positive.
+*
+*  C       (input or output) DOUBLE PRECISION array, dimension (N)
+*          The column scale factors for A.  If EQUED = 'C' or 'B', A is
+*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
+*          is not accessed.  C is an input argument if FACT = 'F';
+*          otherwise, C is an output argument.  If FACT = 'F' and
+*          EQUED = 'C' or 'B', each element of C must be positive.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit,
+*          if EQUED = 'N', B is not modified;
+*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+*          diag(R)*B;
+*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+*          overwritten by diag(C)*B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
+*          to the original system of equations.  Note that A and B are
+*          modified on exit if EQUED .ne. 'N', and the solution to the
+*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and
+*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
+*          and EQUED = 'R' or 'B'.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X.  LDX >= max(1,N).
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The estimate of the reciprocal condition number of the matrix
+*          A after equilibration (if done).  If RCOND is less than the
+*          machine precision (in particular, if RCOND = 0), the matrix
+*          is singular to working precision.  This condition is
+*          indicated by a return code of INFO > 0.
+*
+*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The estimated forward error bound for each solution vector
+*          X(j) (the j-th column of the solution matrix X).
+*          If XTRUE is the true solution corresponding to X(j), FERR(j)
+*          is an estimated upper bound for the magnitude of the largest
+*          element in (X(j) - XTRUE) divided by the magnitude of the
+*          largest element in X(j).  The estimate is as reliable as
+*          the estimate for RCOND, and is almost always a slight
+*          overestimate of the true error.
+*
+*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
+*          The componentwise relative backward error of each solution
+*          vector X(j) (i.e., the smallest relative change in
+*          any element of A or B that makes X(j) an exact solution).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (4*N)
+*          On exit, WORK(1) contains the reciprocal pivot growth
+*          factor norm(A)/norm(U). The "max absolute element" norm is
+*          used. If WORK(1) is much less than 1, then the stability
+*          of the LU factorization of the (equilibrated) matrix A
+*          could be poor. This also means that the solution X, condition
+*          estimator RCOND, and forward error bound FERR could be
+*          unreliable. If factorization fails with 0<INFO<=N, then
+*          WORK(1) contains the reciprocal pivot growth factor for the
+*          leading INFO columns of A.
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, and i is
+*                <= N:  U(i,i) is exactly zero.  The factorization has
+*                       been completed, but the factor U is exactly
+*                       singular, so the solution and error bounds
+*                       could not be computed. RCOND = 0 is returned.
+*                = N+1: U is nonsingular, but RCOND is less than machine
+*                       precision, meaning that the matrix is singular
+*                       to working precision.  Nevertheless, the
+*                       solution and error bounds are computed because
+*                       there are a number of situations where the
+*                       computed solution can be more accurate than the
+*                       value of RCOND would suggest.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+      CHARACTER          NORM
+      INTEGER            I, INFEQU, J
+      DOUBLE PRECISION   AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+     $                   ROWCND, RPVGRW, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANGE, DLANTR
+      EXTERNAL           LSAME, DLAMCH, DLANGE, DLANTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY,
+     $                   DLAQGE, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      NOFACT = LSAME( FACT, 'N' )
+      EQUIL = LSAME( FACT, 'E' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( NOFACT .OR. EQUIL ) THEN
+         EQUED = 'N'
+         ROWEQU = .FALSE.
+         COLEQU = .FALSE.
+      ELSE
+         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         SMLNUM = DLAMCH( 'Safe minimum' )
+         BIGNUM = ONE / SMLNUM
+      END IF
+*
+*     Test the input parameters.
+*
+      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+         INFO = -10
+      ELSE
+         IF( ROWEQU ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 10 J = 1, N
+               RCMIN = MIN( RCMIN, R( J ) )
+               RCMAX = MAX( RCMAX, R( J ) )
+   10       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -11
+            ELSE IF( N.GT.0 ) THEN
+               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               ROWCND = ONE
+            END IF
+         END IF
+         IF( COLEQU .AND. INFO.EQ.0 ) THEN
+            RCMIN = BIGNUM
+            RCMAX = ZERO
+            DO 20 J = 1, N
+               RCMIN = MIN( RCMIN, C( J ) )
+               RCMAX = MAX( RCMAX, C( J ) )
+   20       CONTINUE
+            IF( RCMIN.LE.ZERO ) THEN
+               INFO = -12
+            ELSE IF( N.GT.0 ) THEN
+               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+            ELSE
+               COLCND = ONE
+            END IF
+         END IF
+         IF( INFO.EQ.0 ) THEN
+            IF( LDB.LT.MAX( 1, N ) ) THEN
+               INFO = -14
+            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+               INFO = -16
+            END IF
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGESVX', -INFO )
+         RETURN
+      END IF
+*
+      IF( EQUIL ) THEN
+*
+*        Compute row and column scalings to equilibrate the matrix A.
+*
+         CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+         IF( INFEQU.EQ.0 ) THEN
+*
+*           Equilibrate the matrix.
+*
+            CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+     $                   EQUED )
+            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+         END IF
+      END IF
+*
+*     Scale the right hand side.
+*
+      IF( NOTRAN ) THEN
+         IF( ROWEQU ) THEN
+            DO 40 J = 1, NRHS
+               DO 30 I = 1, N
+                  B( I, J ) = R( I )*B( I, J )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( COLEQU ) THEN
+         DO 60 J = 1, NRHS
+            DO 50 I = 1, N
+               B( I, J ) = C( I )*B( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      IF( NOFACT .OR. EQUIL ) THEN
+*
+*        Compute the LU factorization of A.
+*
+         CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+         CALL DGETRF( N, N, AF, LDAF, IPIV, INFO )
+*
+*        Return if INFO is non-zero.
+*
+         IF( INFO.GT.0 ) THEN
+*
+*           Compute the reciprocal pivot growth factor of the
+*           leading rank-deficient INFO columns of A.
+*
+            RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+     $               WORK )
+            IF( RPVGRW.EQ.ZERO ) THEN
+               RPVGRW = ONE
+            ELSE
+               RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
+            END IF
+            WORK( 1 ) = RPVGRW
+            RCOND = ZERO
+            RETURN
+         END IF
+      END IF
+*
+*     Compute the norm of the matrix A and the
+*     reciprocal pivot growth factor RPVGRW.
+*
+      IF( NOTRAN ) THEN
+         NORM = '1'
+      ELSE
+         NORM = 'I'
+      END IF
+      ANORM = DLANGE( NORM, N, N, A, LDA, WORK )
+      RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
+      IF( RPVGRW.EQ.ZERO ) THEN
+         RPVGRW = ONE
+      ELSE
+         RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
+      END IF
+*
+*     Compute the reciprocal of the condition number of A.
+*
+      CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+*     Compute the solution matrix X.
+*
+      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+      CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+*     Use iterative refinement to improve the computed solution and
+*     compute error bounds and backward error estimates for it.
+*
+      CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+     $             LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+*     Transform the solution matrix X to a solution of the original
+*     system.
+*
+      IF( NOTRAN ) THEN
+         IF( COLEQU ) THEN
+            DO 80 J = 1, NRHS
+               DO 70 I = 1, N
+                  X( I, J ) = C( I )*X( I, J )
+   70          CONTINUE
+   80       CONTINUE
+            DO 90 J = 1, NRHS
+               FERR( J ) = FERR( J ) / COLCND
+   90       CONTINUE
+         END IF
+      ELSE IF( ROWEQU ) THEN
+         DO 110 J = 1, NRHS
+            DO 100 I = 1, N
+               X( I, J ) = R( I )*X( I, J )
+  100       CONTINUE
+  110    CONTINUE
+         DO 120 J = 1, NRHS
+            FERR( J ) = FERR( J ) / ROWCND
+  120    CONTINUE
+      END IF
+*
+      WORK( 1 ) = RPVGRW
+*
+*     Set INFO = N+1 if the matrix is singular to working precision.
+*
+      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+     $   INFO = N + 1
+      RETURN
+*
+*     End of DGESVX
+*
+      END
diff --git a/src/lib/lapack/dgetc2.f b/src/lib/lapack/dgetc2.f
new file mode 100644
index 00000000..5842b213
--- /dev/null
+++ b/src/lib/lapack/dgetc2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGETC2 computes an LU factorization with complete pivoting of the
+*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,
+*  where P and Q are permutation matrices, L is lower triangular with
+*  unit diagonal elements and U is upper triangular.
+*
+*  This is the Level 2 BLAS algorithm.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the n-by-n matrix A to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U*Q; the unit diagonal elements of L are not stored.
+*          If U(k, k) appears to be less than SMIN, U(k, k) is given the
+*          value of SMIN, i.e., giving a nonsingular perturbed system.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension(N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (output) INTEGER array, dimension(N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  INFO    (output) INTEGER
+*           = 0: successful exit
+*           > 0: if INFO = k, U(k, k) is likely to produce owerflow if
+*                we try to solve for x in Ax = b. So U is perturbed to
+*                avoid the overflow.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IP, IPV, J, JP, JPV
+      DOUBLE PRECISION   BIGNUM, EPS, SMIN, SMLNUM, XMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGER, DSWAP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constants to control overflow
+*
+      INFO = 0
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Factorize A using complete pivoting.
+*     Set pivots less than SMIN to SMIN.
+*
+      DO 40 I = 1, N - 1
+*
+*        Find max element in matrix A
+*
+         XMAX = ZERO
+         DO 20 IP = I, N
+            DO 10 JP = I, N
+               IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
+                  XMAX = ABS( A( IP, JP ) )
+                  IPV = IP
+                  JPV = JP
+               END IF
+   10       CONTINUE
+   20    CONTINUE
+         IF( I.EQ.1 )
+     $      SMIN = MAX( EPS*XMAX, SMLNUM )
+*
+*        Swap rows
+*
+         IF( IPV.NE.I )
+     $      CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+         IPIV( I ) = IPV
+*
+*        Swap columns
+*
+         IF( JPV.NE.I )
+     $      CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
+         JPIV( I ) = JPV
+*
+*        Check for singularity
+*
+         IF( ABS( A( I, I ) ).LT.SMIN ) THEN
+            INFO = I
+            A( I, I ) = SMIN
+         END IF
+         DO 30 J = I + 1, N
+            A( J, I ) = A( J, I ) / A( I, I )
+   30    CONTINUE
+         CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
+     $              A( I+1, I+1 ), LDA )
+   40 CONTINUE
+*
+      IF( ABS( A( N, N ) ).LT.SMIN ) THEN
+         INFO = N
+         A( N, N ) = SMIN
+      END IF
+*
+      RETURN
+*
+*     End of DGETC2
+*
+      END
diff --git a/src/lib/lapack/dgetf2.f b/src/lib/lapack/dgetf2.f
new file mode 100644
index 00000000..573b1408
--- /dev/null
+++ b/src/lib/lapack/dgetf2.f
@@ -0,0 +1,147 @@
+      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGETF2 computes an LU factorization of a general m-by-n matrix A
+*  using partial pivoting with row interchanges.
+*
+*  The factorization has the form
+*     A = P * L * U
+*  where P is a permutation matrix, L is lower triangular with unit
+*  diagonal elements (lower trapezoidal if m > n), and U is upper
+*  triangular (upper trapezoidal if m < n).
+*
+*  This is the right-looking Level 2 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n matrix to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  IPIV    (output) INTEGER array, dimension (min(M,N))
+*          The pivot indices; for 1 <= i <= min(M,N), row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+*               has been completed, but the factor U is exactly
+*               singular, and division by zero will occur if it is used
+*               to solve a system of equations.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   SFMIN 
+      INTEGER            I, J, JP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH      
+      INTEGER            IDAMAX
+      EXTERNAL           DLAMCH, IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGETF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum 
+* 
+      SFMIN = DLAMCH('S')  
+*
+      DO 10 J = 1, MIN( M, N )
+*
+*        Find pivot and test for singularity.
+*
+         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+         IF( A( JP, J ).NE.ZERO ) THEN
+*
+*           Apply the interchange to columns 1:N.
+*
+            IF( JP.NE.J )
+     $         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
+*
+*           Compute elements J+1:M of J-th column.
+*
+            IF( J.LT.M ) THEN 
+               IF( ABS(A( J, J )) .GE. SFMIN ) THEN 
+                  CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) 
+               ELSE 
+                 DO 20 I = 1, M-J 
+                    A( J+I, J ) = A( J+I, J ) / A( J, J ) 
+   20            CONTINUE 
+               END IF 
+            END IF 
+*
+         ELSE IF( INFO.EQ.0 ) THEN
+*
+            INFO = J
+         END IF
+*
+         IF( J.LT.MIN( M, N ) ) THEN
+*
+*           Update trailing submatrix.
+*
+            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
+     $                 A( J+1, J+1 ), LDA )
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of DGETF2
+*
+      END
diff --git a/src/lib/lapack/dgetrf.f b/src/lib/lapack/dgetrf.f
new file mode 100644
index 00000000..c5b9df33
--- /dev/null
+++ b/src/lib/lapack/dgetrf.f
@@ -0,0 +1,159 @@
+      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGETRF computes an LU factorization of a general M-by-N matrix A
+*  using partial pivoting with row interchanges.
+*
+*  The factorization has the form
+*     A = P * L * U
+*  where P is a permutation matrix, L is lower triangular with unit
+*  diagonal elements (lower trapezoidal if m > n), and U is upper
+*  triangular (upper trapezoidal if m < n).
+*
+*  This is the right-looking Level 3 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  IPIV    (output) INTEGER array, dimension (min(M,N))
+*          The pivot indices; for 1 <= i <= min(M,N), row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
+*                has been completed, but the factor U is exactly
+*                singular, and division by zero will occur if it is used
+*                to solve a system of equations.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGETRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code.
+*
+         DO 20 J = 1, MIN( M, N ), NB
+            JB = MIN( MIN( M, N )-J+1, NB )
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
+*
+*           Adjust INFO and the pivot indices.
+*
+            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+     $         INFO = IINFO + J - 1
+            DO 10 I = J, MIN( M, J+JB-1 )
+               IPIV( I ) = J - 1 + IPIV( I )
+   10       CONTINUE
+*
+*           Apply interchanges to columns 1:J-1.
+*
+            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply interchanges to columns J+JB:N.
+*
+               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+     $                      IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
+     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
+     $                     LDA )
+               IF( J+JB.LE.M ) THEN
+*
+*                 Update trailing submatrix.
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
+     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
+     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
+     $                        LDA )
+               END IF
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DGETRF
+*
+      END
diff --git a/src/lib/lapack/dgetri.f b/src/lib/lapack/dgetri.f
new file mode 100644
index 00000000..9f1c1182
--- /dev/null
+++ b/src/lib/lapack/dgetri.f
@@ -0,0 +1,192 @@
+      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGETRI computes the inverse of a matrix using the LU factorization
+*  computed by DGETRF.
+*
+*  This method inverts U and then computes inv(A) by solving the system
+*  inv(A)*L = inv(U) for inv(A).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the factors L and U from the factorization
+*          A = P*L*U as computed by DGETRF.
+*          On exit, if INFO = 0, the inverse of the original matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*          For optimal performance LWORK >= N*NB, where NB is
+*          the optimal blocksize returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
+*                singular and its inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGETRI', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form inv(U).  If INFO > 0 from DTRTRI, then U is singular,
+*     and the inverse is not computed.
+*
+      CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+      NBMIN = 2
+      LDWORK = N
+      IF( NB.GT.1 .AND. NB.LT.N ) THEN
+         IWS = MAX( LDWORK*NB, 1 )
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
+         END IF
+      ELSE
+         IWS = N
+      END IF
+*
+*     Solve the equation inv(A)*L = inv(U) for inv(A).
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         DO 20 J = N, 1, -1
+*
+*           Copy current column of L to WORK and replace with zeros.
+*
+            DO 10 I = J + 1, N
+               WORK( I ) = A( I, J )
+               A( I, J ) = ZERO
+   10       CONTINUE
+*
+*           Compute current column of inv(A).
+*
+            IF( J.LT.N )
+     $         CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
+     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
+   20    CONTINUE
+      ELSE
+*
+*        Use blocked code.
+*
+         NN = ( ( N-1 ) / NB )*NB + 1
+         DO 50 J = NN, 1, -NB
+            JB = MIN( NB, N-J+1 )
+*
+*           Copy current block column of L to WORK and replace with
+*           zeros.
+*
+            DO 40 JJ = J, J + JB - 1
+               DO 30 I = JJ + 1, N
+                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
+                  A( I, JJ ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+*
+*           Compute current block column of inv(A).
+*
+            IF( J+JB.LE.N )
+     $         CALL DGEMM( 'No transpose', 'No transpose', N, JB,
+     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
+     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
+            CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
+     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
+   50    CONTINUE
+      END IF
+*
+*     Apply column interchanges.
+*
+      DO 60 J = N - 1, 1, -1
+         JP = IPIV( J )
+         IF( JP.NE.J )
+     $      CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+   60 CONTINUE
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DGETRI
+*
+      END
diff --git a/src/lib/lapack/dgetrs.f b/src/lib/lapack/dgetrs.f
new file mode 100644
index 00000000..b7d17b0a
--- /dev/null
+++ b/src/lib/lapack/dgetrs.f
@@ -0,0 +1,149 @@
+      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGETRS solves a system of linear equations
+*     A * X = B  or  A' * X = B
+*  with a general N-by-N matrix A using the LU factorization computed
+*  by DGETRF.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form of the system of equations:
+*          = 'N':  A * X = B  (No transpose)
+*          = 'T':  A'* X = B  (Transpose)
+*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by DGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from DGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit, the solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASWP, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGETRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve A * X = B.
+*
+*        Apply row interchanges to the right hand sides.
+*
+         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+      ELSE
+*
+*        Solve A' * X = B.
+*
+*        Solve U'*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
+     $               A, LDA, B, LDB )
+*
+*        Apply row interchanges to the solution vectors.
+*
+         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+      END IF
+*
+      RETURN
+*
+*     End of DGETRS
+*
+      END
diff --git a/src/lib/lapack/dggbak.f b/src/lib/lapack/dggbak.f
new file mode 100644
index 00000000..8ed9fbd4
--- /dev/null
+++ b/src/lib/lapack/dggbak.f
@@ -0,0 +1,220 @@
+      SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
+     $                   LDV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB, SIDE
+      INTEGER            IHI, ILO, INFO, LDV, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGBAK forms the right or left eigenvectors of a real generalized
+*  eigenvalue problem A*x = lambda*B*x, by backward transformation on
+*  the computed eigenvectors of the balanced pair of matrices output by
+*  DGGBAL.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the type of backward transformation required:
+*          = 'N':  do nothing, return immediately;
+*          = 'P':  do backward transformation for permutation only;
+*          = 'S':  do backward transformation for scaling only;
+*          = 'B':  do backward transformations for both permutation and
+*                  scaling.
+*          JOB must be the same as the argument JOB supplied to DGGBAL.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  V contains right eigenvectors;
+*          = 'L':  V contains left eigenvectors.
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrix V.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          The integers ILO and IHI determined by DGGBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  LSCALE  (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the left side of A and B, as returned by DGGBAL.
+*
+*  RSCALE  (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the right side of A and B, as returned by DGGBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by DTGEVC.
+*          On exit, V is overwritten by the transformed eigenvectors.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the matrix V. LDV >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  See R.C. Ward, Balancing the generalized eigenvalue problem,
+*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, K
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      RIGHTV = LSAME( SIDE, 'R' )
+      LEFTV = LSAME( SIDE, 'L' )
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
+         INFO = -4
+      ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
+     $   THEN
+         INFO = -5
+      ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -8
+      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGBAK', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( LSAME( JOB, 'N' ) )
+     $   RETURN
+*
+      IF( ILO.EQ.IHI )
+     $   GO TO 30
+*
+*     Backward balance
+*
+      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+*        Backward transformation on right eigenvectors
+*
+         IF( RIGHTV ) THEN
+            DO 10 I = ILO, IHI
+               CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+*        Backward transformation on left eigenvectors
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Backward permutation
+*
+   30 CONTINUE
+      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+*        Backward permutation on right eigenvectors
+*
+         IF( RIGHTV ) THEN
+            IF( ILO.EQ.1 )
+     $         GO TO 50
+*
+            DO 40 I = ILO - 1, 1, -1
+               K = RSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 40
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   40       CONTINUE
+*
+   50       CONTINUE
+            IF( IHI.EQ.N )
+     $         GO TO 70
+            DO 60 I = IHI + 1, N
+               K = RSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 60
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   60       CONTINUE
+         END IF
+*
+*        Backward permutation on left eigenvectors
+*
+   70    CONTINUE
+         IF( LEFTV ) THEN
+            IF( ILO.EQ.1 )
+     $         GO TO 90
+            DO 80 I = ILO - 1, 1, -1
+               K = LSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 80
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   80       CONTINUE
+*
+   90       CONTINUE
+            IF( IHI.EQ.N )
+     $         GO TO 110
+            DO 100 I = IHI + 1, N
+               K = LSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 100
+               CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+  100       CONTINUE
+         END IF
+      END IF
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of DGGBAK
+*
+      END
diff --git a/src/lib/lapack/dggbal.f b/src/lib/lapack/dggbal.f
new file mode 100644
index 00000000..2034880a
--- /dev/null
+++ b/src/lib/lapack/dggbal.f
@@ -0,0 +1,469 @@
+      SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
+     $                   RSCALE, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            IHI, ILO, INFO, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), LSCALE( * ),
+     $                   RSCALE( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGBAL balances a pair of general real matrices (A,B).  This
+*  involves, first, permuting A and B by similarity transformations to
+*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
+*  elements on the diagonal; and second, applying a diagonal similarity
+*  transformation to rows and columns ILO to IHI to make the rows
+*  and columns as close in norm as possible. Both steps are optional.
+*
+*  Balancing may reduce the 1-norm of the matrices, and improve the
+*  accuracy of the computed eigenvalues and/or eigenvectors in the
+*  generalized eigenvalue problem A*x = lambda*B*x.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the operations to be performed on A and B:
+*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
+*                  and RSCALE(I) = 1.0 for i = 1,...,N.
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the input matrix A.
+*          On exit,  A is overwritten by the balanced matrix.
+*          If JOB = 'N', A is not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the input matrix B.
+*          On exit,  B is overwritten by the balanced matrix.
+*          If JOB = 'N', B is not referenced.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are set to integers such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If P(j) is the index of the
+*          row interchanged with row j, and D(j)
+*          is the scaling factor applied to row j, then
+*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
+*                      = D(j)    for J = ILO,...,IHI
+*                      = P(j)    for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If P(j) is the index of the
+*          column interchanged with column j, and D(j)
+*          is the scaling factor applied to column j, then
+*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
+*                      = D(j)    for J = ILO,...,IHI
+*                      = P(j)    for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  WORK    (workspace) REAL array, dimension (lwork)
+*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
+*          at least 1 when JOB = 'N' or 'P'.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  See R.C. WARD, Balancing the generalized eigenvalue problem,
+*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   THREE, SCLFAC
+      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
+     $                   K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
+     $                   M, NR, NRP2
+      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
+     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
+     $                   SFMIN, SUM, T, TA, TB, TC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGBAL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         ILO = 1
+         IHI = N
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         ILO = 1
+         IHI = N
+         LSCALE( 1 ) = ONE
+         RSCALE( 1 ) = ONE
+         RETURN
+      END IF
+*
+      IF( LSAME( JOB, 'N' ) ) THEN
+         ILO = 1
+         IHI = N
+         DO 10 I = 1, N
+            LSCALE( I ) = ONE
+            RSCALE( I ) = ONE
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      K = 1
+      L = N
+      IF( LSAME( JOB, 'S' ) )
+     $   GO TO 190
+*
+      GO TO 30
+*
+*     Permute the matrices A and B to isolate the eigenvalues.
+*
+*     Find row with one nonzero in columns 1 through L
+*
+   20 CONTINUE
+      L = LM1
+      IF( L.NE.1 )
+     $   GO TO 30
+*
+      RSCALE( 1 ) = ONE
+      LSCALE( 1 ) = ONE
+      GO TO 190
+*
+   30 CONTINUE
+      LM1 = L - 1
+      DO 80 I = L, 1, -1
+         DO 40 J = 1, LM1
+            JP1 = J + 1
+            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+     $         GO TO 50
+   40    CONTINUE
+         J = L
+         GO TO 70
+*
+   50    CONTINUE
+         DO 60 J = JP1, L
+            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+     $         GO TO 80
+   60    CONTINUE
+         J = JP1 - 1
+*
+   70    CONTINUE
+         M = L
+         IFLOW = 1
+         GO TO 160
+   80 CONTINUE
+      GO TO 100
+*
+*     Find column with one nonzero in rows K through N
+*
+   90 CONTINUE
+      K = K + 1
+*
+  100 CONTINUE
+      DO 150 J = K, L
+         DO 110 I = K, LM1
+            IP1 = I + 1
+            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+     $         GO TO 120
+  110    CONTINUE
+         I = L
+         GO TO 140
+  120    CONTINUE
+         DO 130 I = IP1, L
+            IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+     $         GO TO 150
+  130    CONTINUE
+         I = IP1 - 1
+  140    CONTINUE
+         M = K
+         IFLOW = 2
+         GO TO 160
+  150 CONTINUE
+      GO TO 190
+*
+*     Permute rows M and I
+*
+  160 CONTINUE
+      LSCALE( M ) = I
+      IF( I.EQ.M )
+     $   GO TO 170
+      CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+      CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
+*
+*     Permute columns M and J
+*
+  170 CONTINUE
+      RSCALE( M ) = J
+      IF( J.EQ.M )
+     $   GO TO 180
+      CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
+*
+  180 CONTINUE
+      GO TO ( 20, 90 )IFLOW
+*
+  190 CONTINUE
+      ILO = K
+      IHI = L
+*
+      IF( LSAME( JOB, 'P' ) ) THEN
+         DO 195 I = ILO, IHI
+            LSCALE( I ) = ONE
+            RSCALE( I ) = ONE
+  195    CONTINUE
+         RETURN
+      END IF
+*
+      IF( ILO.EQ.IHI )
+     $   RETURN
+*
+*     Balance the submatrix in rows ILO to IHI.
+*
+      NR = IHI - ILO + 1
+      DO 200 I = ILO, IHI
+         RSCALE( I ) = ZERO
+         LSCALE( I ) = ZERO
+*
+         WORK( I ) = ZERO
+         WORK( I+N ) = ZERO
+         WORK( I+2*N ) = ZERO
+         WORK( I+3*N ) = ZERO
+         WORK( I+4*N ) = ZERO
+         WORK( I+5*N ) = ZERO
+  200 CONTINUE
+*
+*     Compute right side vector in resulting linear equations
+*
+      BASL = LOG10( SCLFAC )
+      DO 240 I = ILO, IHI
+         DO 230 J = ILO, IHI
+            TB = B( I, J )
+            TA = A( I, J )
+            IF( TA.EQ.ZERO )
+     $         GO TO 210
+            TA = LOG10( ABS( TA ) ) / BASL
+  210       CONTINUE
+            IF( TB.EQ.ZERO )
+     $         GO TO 220
+            TB = LOG10( ABS( TB ) ) / BASL
+  220       CONTINUE
+            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
+            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
+  230    CONTINUE
+  240 CONTINUE
+*
+      COEF = ONE / DBLE( 2*NR )
+      COEF2 = COEF*COEF
+      COEF5 = HALF*COEF2
+      NRP2 = NR + 2
+      BETA = ZERO
+      IT = 1
+*
+*     Start generalized conjugate gradient iteration
+*
+  250 CONTINUE
+*
+      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+     $        DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
+*
+      EW = ZERO
+      EWC = ZERO
+      DO 260 I = ILO, IHI
+         EW = EW + WORK( I+4*N )
+         EWC = EWC + WORK( I+5*N )
+  260 CONTINUE
+*
+      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
+      IF( GAMMA.EQ.ZERO )
+     $   GO TO 350
+      IF( IT.NE.1 )
+     $   BETA = GAMMA / PGAMMA
+      T = COEF5*( EWC-THREE*EW )
+      TC = COEF5*( EW-THREE*EWC )
+*
+      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
+      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
+*
+      DO 270 I = ILO, IHI
+         WORK( I ) = WORK( I ) + TC
+         WORK( I+N ) = WORK( I+N ) + T
+  270 CONTINUE
+*
+*     Apply matrix to vector
+*
+      DO 300 I = ILO, IHI
+         KOUNT = 0
+         SUM = ZERO
+         DO 290 J = ILO, IHI
+            IF( A( I, J ).EQ.ZERO )
+     $         GO TO 280
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( J )
+  280       CONTINUE
+            IF( B( I, J ).EQ.ZERO )
+     $         GO TO 290
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( J )
+  290    CONTINUE
+         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
+  300 CONTINUE
+*
+      DO 330 J = ILO, IHI
+         KOUNT = 0
+         SUM = ZERO
+         DO 320 I = ILO, IHI
+            IF( A( I, J ).EQ.ZERO )
+     $         GO TO 310
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( I+N )
+  310       CONTINUE
+            IF( B( I, J ).EQ.ZERO )
+     $         GO TO 320
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( I+N )
+  320    CONTINUE
+         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
+  330 CONTINUE
+*
+      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+     $      DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
+      ALPHA = GAMMA / SUM
+*
+*     Determine correction to current iteration
+*
+      CMAX = ZERO
+      DO 340 I = ILO, IHI
+         COR = ALPHA*WORK( I+N )
+         IF( ABS( COR ).GT.CMAX )
+     $      CMAX = ABS( COR )
+         LSCALE( I ) = LSCALE( I ) + COR
+         COR = ALPHA*WORK( I )
+         IF( ABS( COR ).GT.CMAX )
+     $      CMAX = ABS( COR )
+         RSCALE( I ) = RSCALE( I ) + COR
+  340 CONTINUE
+      IF( CMAX.LT.HALF )
+     $   GO TO 350
+*
+      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
+*
+      PGAMMA = GAMMA
+      IT = IT + 1
+      IF( IT.LE.NRP2 )
+     $   GO TO 250
+*
+*     End generalized conjugate gradient iteration
+*
+  350 CONTINUE
+      SFMIN = DLAMCH( 'S' )
+      SFMAX = ONE / SFMIN
+      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+      LSFMAX = INT( LOG10( SFMAX ) / BASL )
+      DO 360 I = ILO, IHI
+         IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
+         RAB = ABS( A( I, IRAB+ILO-1 ) )
+         IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB )
+         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
+         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
+         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
+         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
+         LSCALE( I ) = SCLFAC**IR
+         ICAB = IDAMAX( IHI, A( 1, I ), 1 )
+         CAB = ABS( A( ICAB, I ) )
+         ICAB = IDAMAX( IHI, B( 1, I ), 1 )
+         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
+         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
+         JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
+         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
+         RSCALE( I ) = SCLFAC**JC
+  360 CONTINUE
+*
+*     Row scaling of matrices A and B
+*
+      DO 370 I = ILO, IHI
+         CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+         CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+  370 CONTINUE
+*
+*     Column scaling of matrices A and B
+*
+      DO 380 J = ILO, IHI
+         CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+         CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+  380 CONTINUE
+*
+      RETURN
+*
+*     End of DGGBAL
+*
+      END
diff --git a/src/lib/lapack/dgges.f b/src/lib/lapack/dgges.f
new file mode 100644
index 00000000..ce29aa52
--- /dev/null
+++ b/src/lib/lapack/dgges.f
@@ -0,0 +1,550 @@
+      SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, DELCTG, N, A, LDA, B, LDB,
+     $                  SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
+     $                  LDVSR, WORK, LWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     June 30, 1999
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVSL, JOBVSR, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+     $                   VSR( LDVSR, * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            DELCTG
+      EXTERNAL           DELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
+*  the generalized eigenvalues, the generalized real Schur form (S,T),
+*  optionally, the left and/or right matrices of Schur vectors (VSL and
+*  VSR). This gives the generalized Schur factorization
+*
+*           (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
+*
+*  Optionally, it also orders the eigenvalues so that a selected cluster
+*  of eigenvalues appears in the leading diagonal blocks of the upper
+*  quasi-triangular matrix S and the upper triangular matrix T.The
+*  leading columns of VSL and VSR then form an orthonormal basis for the
+*  corresponding left and right eigenspaces (deflating subspaces).
+*
+*  (If only the generalized eigenvalues are needed, use the driver
+*  DGGEV instead, which is faster.)
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0 or both being zero.
+*
+*  A pair of matrices (S,T) is in generalized real Schur form if T is
+*  upper triangular with non-negative diagonal and S is block upper
+*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
+*  to real generalized eigenvalues, while 2-by-2 blocks of S will be
+*  "standardized" by making the corresponding elements of T have the
+*  form:
+*          [  a  0  ]
+*          [  0  b  ]
+*
+*  and the pair of corresponding 2-by-2 blocks in S and T will have a
+*  complex conjugate pair of generalized eigenvalues.
+*
+*
+*  Arguments
+*  =========
+*
+*  JOBVSL  (input) CHARACTER*1
+*          = 'N':  do not compute the left Schur vectors;
+*          = 'V':  compute the left Schur vectors.
+*
+*  JOBVSR  (input) CHARACTER*1
+*          = 'N':  do not compute the right Schur vectors;
+*          = 'V':  compute the right Schur vectors.
+*
+*  SORT    (input) CHARACTER*1
+*          Specifies whether or not to order the eigenvalues on the
+*          diagonal of the generalized Schur form.
+*          = 'N':  Eigenvalues are not ordered;
+*          = 'S':  Eigenvalues are ordered (see DELZTG);
+*
+*  DELZTG  (input) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
+*          DELZTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', DELZTG is not referenced.
+*          If SORT = 'S', DELZTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+*          DELZTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+*          one of a complex conjugate pair of eigenvalues is selected,
+*          then both complex eigenvalues are selected.
+*
+*          Note that in the ill-conditioned case, a selected complex
+*          eigenvalue may no longer satisfy DELZTG(ALPHAR(j),ALPHAI(j),
+*          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
+*          in this case.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the first of the pair of matrices.
+*          On exit, A has been overwritten by its generalized Schur
+*          form S.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+*          On entry, the second of the pair of matrices.
+*          On exit, B has been overwritten by its generalized Schur
+*          form T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  SDIM    (output) INTEGER
+*          If SORT = 'N', SDIM = 0.
+*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+*          for which DELZTG is true.  (Complex conjugate pairs for which
+*          DELZTG is true for either eigenvalue count as 2.)
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,
+*          and  BETA(j),j=1,...,N are the diagonals of the complex Schur
+*          form (S,T) that would result if the 2-by-2 diagonal blocks of
+*          the real Schur form of (A,B) were further reduced to
+*          triangular form using 2-by-2 complex unitary transformations.
+*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+*          positive, then the j-th and (j+1)-st eigenvalues are a
+*          complex conjugate pair, with ALPHAI(j+1) negative.
+*
+*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+*          may easily over- or underflow, and BETA(j) may even be zero.
+*          Thus, the user should avoid naively computing the ratio.
+*          However, ALPHAR and ALPHAI will be always less than and
+*          usually comparable with norm(A) in magnitude, and BETA always
+*          less than and usually comparable with norm(B).
+*
+*  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)
+*          If JOBVSL = 'V', VSL will contain the left Schur vectors.
+*          Not referenced if JOBVSL = 'N'.
+*
+*  LDVSL   (input) INTEGER
+*          The leading dimension of the matrix VSL. LDVSL >=1, and
+*          if JOBVSL = 'V', LDVSL >= N.
+*
+*  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)
+*          If JOBVSR = 'V', VSR will contain the right Schur vectors.
+*          Not referenced if JOBVSR = 'N'.
+*
+*  LDVSR   (input) INTEGER
+*          The leading dimension of the matrix VSR. LDVSR >= 1, and
+*          if JOBVSR = 'V', LDVSR >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= 8*N+16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          Not referenced if SORT = 'N'.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1,...,N:
+*                The QZ iteration failed.  (A,B) are not in Schur
+*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+*                be correct for j=INFO+1,...,N.
+*          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
+*                =N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Generalized Schur form no
+*                      longer satisfy DELZTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering failed in DTGSEN.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, LST2SL, WANTST
+      INTEGER            I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
+     $                   ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK,
+     $                   MINWRK
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+     $                   PVSR, SAFMAX, SAFMIN, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      DOUBLE PRECISION   DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+     $                   DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+      WANTST = LSAME( SORT, 'S' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -15
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -17
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      MINWRK = 1
+      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
+         MINWRK = 7*( N+1 ) + 16
+         MAXWRK = 7*( N+1 ) + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) +
+     $            16
+         IF( ILVSL ) THEN
+            MAXWRK = MAX( MAXWRK, 7*( N+1 )+N*
+     $               ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
+         END IF
+         WORK( 1 ) = MAXWRK
+      END IF
+*
+      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+     $   INFO = -19
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGES ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      SMLNUM = SQRT( SAFMIN ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Workspace: need 6*N + 2*N space for storing balancing factors)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWRK = IRIGHT + N
+      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+     $             WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = IWRK
+      IWRK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VSL
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVSL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+         CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                VSL( ILO+1, ILO ), LDVSL )
+         CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IERR )
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     (Workspace: need N)
+*
+      IWRK = ITAU
+      CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 50
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA if desired
+*     (Workspace: need 4*N+16 )
+*
+      SDIM = 0
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before DELZTGing
+*
+         IF( ILASCL ) THEN
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+     $                   IERR )
+            CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+     $                   IERR )
+         END IF
+         IF( ILBSCL )
+     $      CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+   10    CONTINUE
+*
+         CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
+     $                ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
+     $                PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+     $                IERR )
+         IF( IERR.EQ.1 )
+     $      INFO = N + 3
+*
+      END IF
+*
+*     Apply back-permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+      IF( ILVSR )
+     $   CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Check if unscaling would cause over/underflow, if so, rescale
+*     (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+*     B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+      IF( ILASCL ) THEN
+         DO 20 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+     $             ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
+                  WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
+     $                  ( ANRMTO / ANRM ) .OR.
+     $                  ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+     $                   THEN
+                  WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   20    CONTINUE
+      END IF
+*
+      IF( ILBSCL ) THEN
+         DO 30 I = 1, N
+            IF( ALPHAI( I ).NE.ZERO ) THEN
+               IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+     $             ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+                  WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+                  BETA( I ) = BETA( I )*WORK( 1 )
+                  ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+                  ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+               END IF
+            END IF
+   30    CONTINUE
+      END IF
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+      IF( WANTST ) THEN
+*
+*        Check if reordering is correct
+*
+         LASTSL = .TRUE.
+         LST2SL = .TRUE.
+         SDIM = 0
+         IP = 0
+         DO 40 I = 1, N
+            CURSL = DELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+            IF( ALPHAI( I ).EQ.ZERO ) THEN
+               IF( CURSL )
+     $            SDIM = SDIM + 1
+               IP = 0
+               IF( CURSL .AND. .NOT.LASTSL )
+     $            INFO = N + 2
+            ELSE
+               IF( IP.EQ.1 ) THEN
+*
+*                 Last eigenvalue of conjugate pair
+*
+                  CURSL = CURSL .OR. LASTSL
+                  LASTSL = CURSL
+                  IF( CURSL )
+     $               SDIM = SDIM + 2
+                  IP = -1
+                  IF( CURSL .AND. .NOT.LST2SL )
+     $               INFO = N + 2
+               ELSE
+*
+*                 First eigenvalue of conjugate pair
+*
+                  IP = 1
+               END IF
+            END IF
+            LST2SL = LASTSL
+            LASTSL = CURSL
+   40    CONTINUE
+*
+      END IF
+*
+   50 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGGES
+*
+      END
diff --git a/src/lib/lapack/dggev.f b/src/lib/lapack/dggev.f
new file mode 100644
index 00000000..4a204c33
--- /dev/null
+++ b/src/lib/lapack/dggev.f
@@ -0,0 +1,489 @@
+      SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
+     $                  BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVL, JOBVR
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+*  the generalized eigenvalues, and optionally, the left and/or right
+*  generalized eigenvectors.
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   A * v(j) = lambda(j) * B * v(j).
+*
+*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+*  of (A,B) satisfies
+*
+*                   u(j)**H * A  = lambda(j) * u(j)**H * B .
+*
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the matrix A in the pair (A,B).
+*          On exit, A has been overwritten.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+*          On entry, the matrix B in the pair (A,B).
+*          On exit, B has been overwritten.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+*          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
+*          the j-th eigenvalue is real; if positive, then the j-th and
+*          (j+1)-st eigenvalues are a complex conjugate pair, with
+*          ALPHAI(j+1) negative.
+*
+*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+*          may easily over- or underflow, and BETA(j) may even be zero.
+*          Thus, the user should avoid naively computing the ratio
+*          alpha/beta.  However, ALPHAR and ALPHAI will be always less
+*          than and usually comparable with norm(A) in magnitude, and
+*          BETA always less than and usually comparable with norm(B).
+*
+*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored one
+*          after another in the columns of VL, in the same order as
+*          their eigenvalues. If the j-th eigenvalue is real, then
+*          u(j) = VL(:,j), the j-th column of VL. If the j-th and
+*          (j+1)-th eigenvalues form a complex conjugate pair, then
+*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+*          Each eigenvector is scaled so the largest component has
+*          abs(real part)+abs(imag. part)=1.
+*          Not referenced if JOBVL = 'N'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the matrix VL. LDVL >= 1, and
+*          if JOBVL = 'V', LDVL >= N.
+*
+*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors v(j) are stored one
+*          after another in the columns of VR, in the same order as
+*          their eigenvalues. If the j-th eigenvalue is real, then
+*          v(j) = VR(:,j), the j-th column of VR. If the j-th and
+*          (j+1)-th eigenvalues form a complex conjugate pair, then
+*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+*          Each eigenvector is scaled so the largest component has
+*          abs(real part)+abs(imag. part)=1.
+*          Not referenced if JOBVR = 'N'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the matrix VR. LDVR >= 1, and
+*          if JOBVR = 'V', LDVR >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,8*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          = 1,...,N:
+*                The QZ iteration failed.  No eigenvectors have been
+*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+*                should be correct for j=INFO+1,...,N.
+*          > N:  =N+1: other than QZ iteration failed in DHGEQZ.
+*                =N+2: error return from DTGEVC.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
+     $                   MINWRK
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+     $                   DLACPY,DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVL = .FALSE.
+      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVR = .FALSE.
+      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVR = .FALSE.
+      END IF
+      ILV = ILVL .OR. ILVR
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -12
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -14
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         MINWRK = MAX( 1, 8*N )
+         MAXWRK = MAX( 1, N*( 7 +
+     $                 ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) )
+         MAXWRK = MAX( MAXWRK, N*( 7 +
+     $                 ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) )
+         IF( ILVL ) THEN
+            MAXWRK = MAX( MAXWRK, N*( 7 +
+     $                 ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+     $      INFO = -16
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrices A, B to isolate eigenvalues if possible
+*     (Workspace: need 6*N)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IWRK = IRIGHT + N
+      CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+     $             WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = IWRK
+      IWRK = ITAU + IROWS
+      CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Workspace: need N, prefer N*NB)
+*
+      CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VL
+*     (Workspace: need N, prefer N*NB)
+*
+      IF( ILVL ) THEN
+         CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VR
+*
+      IF( ILVR )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+      END IF
+*
+*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
+*     Schur forms and Schur vectors)
+*     (Workspace: need N)
+*
+      IWRK = ITAU
+      IF( ILV ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+      CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 110
+      END IF
+*
+*     Compute Eigenvectors
+*     (Workspace: need 6*N)
+*
+      IF( ILV ) THEN
+         IF( ILVL ) THEN
+            IF( ILVR ) THEN
+               CHTEMP = 'B'
+            ELSE
+               CHTEMP = 'L'
+            END IF
+         ELSE
+            CHTEMP = 'R'
+         END IF
+         CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+     $                VR, LDVR, N, IN, WORK( IWRK ), IERR )
+         IF( IERR.NE.0 ) THEN
+            INFO = N + 2
+            GO TO 110
+         END IF
+*
+*        Undo balancing on VL and VR and normalization
+*        (Workspace: none needed)
+*
+         IF( ILVL ) THEN
+            CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+     $                   WORK( IRIGHT ), N, VL, LDVL, IERR )
+            DO 50 JC = 1, N
+               IF( ALPHAI( JC ).LT.ZERO )
+     $            GO TO 50
+               TEMP = ZERO
+               IF( ALPHAI( JC ).EQ.ZERO ) THEN
+                  DO 10 JR = 1, N
+                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+   10             CONTINUE
+               ELSE
+                  DO 20 JR = 1, N
+                     TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+     $                      ABS( VL( JR, JC+1 ) ) )
+   20             CONTINUE
+               END IF
+               IF( TEMP.LT.SMLNUM )
+     $            GO TO 50
+               TEMP = ONE / TEMP
+               IF( ALPHAI( JC ).EQ.ZERO ) THEN
+                  DO 30 JR = 1, N
+                     VL( JR, JC ) = VL( JR, JC )*TEMP
+   30             CONTINUE
+               ELSE
+                  DO 40 JR = 1, N
+                     VL( JR, JC ) = VL( JR, JC )*TEMP
+                     VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+   40             CONTINUE
+               END IF
+   50       CONTINUE
+         END IF
+         IF( ILVR ) THEN
+            CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+     $                   WORK( IRIGHT ), N, VR, LDVR, IERR )
+            DO 100 JC = 1, N
+               IF( ALPHAI( JC ).LT.ZERO )
+     $            GO TO 100
+               TEMP = ZERO
+               IF( ALPHAI( JC ).EQ.ZERO ) THEN
+                  DO 60 JR = 1, N
+                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+   60             CONTINUE
+               ELSE
+                  DO 70 JR = 1, N
+                     TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+     $                      ABS( VR( JR, JC+1 ) ) )
+   70             CONTINUE
+               END IF
+               IF( TEMP.LT.SMLNUM )
+     $            GO TO 100
+               TEMP = ONE / TEMP
+               IF( ALPHAI( JC ).EQ.ZERO ) THEN
+                  DO 80 JR = 1, N
+                     VR( JR, JC ) = VR( JR, JC )*TEMP
+   80             CONTINUE
+               ELSE
+                  DO 90 JR = 1, N
+                     VR( JR, JC ) = VR( JR, JC )*TEMP
+                     VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+   90             CONTINUE
+               END IF
+  100       CONTINUE
+         END IF
+*
+*        End of eigenvector calculation
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ILASCL ) THEN
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+         CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+  110 CONTINUE
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of DGGEV
+*
+      END
diff --git a/src/lib/lapack/dgghrd.f b/src/lib/lapack/dgghrd.f
new file mode 100644
index 00000000..6b8bbb08
--- /dev/null
+++ b/src/lib/lapack/dgghrd.f
@@ -0,0 +1,264 @@
+      SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
+     $                   LDQ, Z, LDZ, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, COMPZ
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGGHRD reduces a pair of real matrices (A,B) to generalized upper
+*  Hessenberg form using orthogonal transformations, where A is a
+*  general matrix and B is upper triangular.  The form of the
+*  generalized eigenvalue problem is
+*     A*x = lambda*B*x,
+*  and B is typically made upper triangular by computing its QR
+*  factorization and moving the orthogonal matrix Q to the left side
+*  of the equation.
+*
+*  This subroutine simultaneously reduces A to a Hessenberg matrix H:
+*     Q**T*A*Z = H
+*  and transforms B to another upper triangular matrix T:
+*     Q**T*B*Z = T
+*  in order to reduce the problem to its standard form
+*     H*y = lambda*T*y
+*  where y = Z**T*x.
+*
+*  The orthogonal matrices Q and Z are determined as products of Givens
+*  rotations.  They may either be formed explicitly, or they may be
+*  postmultiplied into input matrices Q1 and Z1, so that
+*
+*       Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
+*
+*       Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
+*
+*  If Q1 is the orthogonal matrix from the QR factorization of B in the
+*  original equation A*x = lambda*B*x, then DGGHRD reduces the original
+*  problem to generalized Hessenberg form.
+*
+*  Arguments
+*  =========
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'N': do not compute Q;
+*          = 'I': Q is initialized to the unit matrix, and the
+*                 orthogonal matrix Q is returned;
+*          = 'V': Q must contain an orthogonal matrix Q1 on entry,
+*                 and the product Q1*Q is returned.
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N': do not compute Z;
+*          = 'I': Z is initialized to the unit matrix, and the
+*                 orthogonal matrix Z is returned;
+*          = 'V': Z must contain an orthogonal matrix Z1 on entry,
+*                 and the product Z1*Z is returned.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI mark the rows and columns of A which are to be
+*          reduced.  It is assumed that A is already upper triangular
+*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
+*          normally set by a previous call to SGGBAL; otherwise they
+*          should be set to 1 and N respectively.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the N-by-N general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          rest is set to zero.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+*          On entry, the N-by-N upper triangular matrix B.
+*          On exit, the upper triangular matrix T = Q**T B Z.  The
+*          elements below the diagonal are set to zero.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+*          On entry, if COMPQ = 'V', the orthogonal matrix Q1,
+*          typically from the QR factorization of B.
+*          On exit, if COMPQ='I', the orthogonal matrix Q, and if
+*          COMPQ = 'V', the product Q1*Q.
+*          Not referenced if COMPQ='N'.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the orthogonal matrix Z1.
+*          On exit, if COMPZ='I', the orthogonal matrix Z, and if
+*          COMPZ = 'V', the product Z1*Z.
+*          Not referenced if COMPZ='N'.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.
+*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  This routine reduces A to Hessenberg and B to triangular form by
+*  an unblocked reduction, as described in _Matrix_Computations_,
+*  by Golub and Van Loan (Johns Hopkins Press.)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILQ, ILZ
+      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
+      DOUBLE PRECISION   C, S, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARTG, DLASET, DROT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode COMPQ
+*
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ILQ = .FALSE.
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 2
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 3
+      ELSE
+         ICOMPQ = 0
+      END IF
+*
+*     Decode COMPZ
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ILZ = .FALSE.
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 2
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 3
+      ELSE
+         ICOMPZ = 0
+      END IF
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ICOMPQ.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPZ.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
+         INFO = -11
+      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DGGHRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z if desired.
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Zero out lower triangle of B
+*
+      DO 20 JCOL = 1, N - 1
+         DO 10 JROW = JCOL + 1, N
+            B( JROW, JCOL ) = ZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     Reduce A and B
+*
+      DO 40 JCOL = ILO, IHI - 2
+*
+         DO 30 JROW = IHI, JCOL + 2, -1
+*
+*           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
+*
+            TEMP = A( JROW-1, JCOL )
+            CALL DLARTG( TEMP, A( JROW, JCOL ), C, S,
+     $                   A( JROW-1, JCOL ) )
+            A( JROW, JCOL ) = ZERO
+            CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+     $                 A( JROW, JCOL+1 ), LDA, C, S )
+            CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+     $                 B( JROW, JROW-1 ), LDB, C, S )
+            IF( ILQ )
+     $         CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
+*
+*           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
+*
+            TEMP = B( JROW, JROW )
+            CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S,
+     $                   B( JROW, JROW ) )
+            B( JROW, JROW-1 ) = ZERO
+            CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+            CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+     $                 S )
+            IF( ILZ )
+     $         CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+   30    CONTINUE
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of DGGHRD
+*
+      END
diff --git a/src/lib/lapack/dhgeqz.f b/src/lib/lapack/dhgeqz.f
new file mode 100644
index 00000000..de137dc1
--- /dev/null
+++ b/src/lib/lapack/dhgeqz.f
@@ -0,0 +1,1243 @@
+      SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
+     $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
+     $                   LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, COMPZ, JOB
+      INTEGER            IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   ALPHAI( * ), ALPHAR( * ), BETA( * ),
+     $                   H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DHGEQZ computes the eigenvalues of a real matrix pair (H,T),
+*  where H is an upper Hessenberg matrix and T is upper triangular,
+*  using the double-shift QZ method.
+*  Matrix pairs of this type are produced by the reduction to
+*  generalized upper Hessenberg form of a real matrix pair (A,B):
+*
+*     A = Q1*H*Z1**T,  B = Q1*T*Z1**T,
+*
+*  as computed by DGGHRD.
+*
+*  If JOB='S', then the Hessenberg-triangular pair (H,T) is
+*  also reduced to generalized Schur form,
+*  
+*     H = Q*S*Z**T,  T = Q*P*Z**T,
+*  
+*  where Q and Z are orthogonal matrices, P is an upper triangular
+*  matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
+*  diagonal blocks.
+*
+*  The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
+*  (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
+*  eigenvalues.
+*
+*  Additionally, the 2-by-2 upper triangular diagonal blocks of P
+*  corresponding to 2-by-2 blocks of S are reduced to positive diagonal
+*  form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
+*  P(j,j) > 0, and P(j+1,j+1) > 0.
+*
+*  Optionally, the orthogonal matrix Q from the generalized Schur
+*  factorization may be postmultiplied into an input matrix Q1, and the
+*  orthogonal matrix Z may be postmultiplied into an input matrix Z1.
+*  If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
+*  the matrix pair (A,B) to generalized upper Hessenberg form, then the
+*  output matrices Q1*Q and Z1*Z are the orthogonal factors from the
+*  generalized Schur factorization of (A,B):
+*
+*     A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.
+*  
+*  To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
+*  of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
+*  complex and beta real.
+*  If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
+*  generalized nonsymmetric eigenvalue problem (GNEP)
+*     A*x = lambda*B*x
+*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
+*  alternate form of the GNEP
+*     mu*A*y = B*y.
+*  Real eigenvalues can be read directly from the generalized Schur
+*  form: 
+*    alpha = S(i,i), beta = P(i,i).
+*
+*  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
+*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
+*       pp. 241--256.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          = 'E': Compute eigenvalues only;
+*          = 'S': Compute eigenvalues and the Schur form. 
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'N': Left Schur vectors (Q) are not computed;
+*          = 'I': Q is initialized to the unit matrix and the matrix Q
+*                 of left Schur vectors of (H,T) is returned;
+*          = 'V': Q must contain an orthogonal matrix Q1 on entry and
+*                 the product Q1*Q is returned.
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N': Right Schur vectors (Z) are not computed;
+*          = 'I': Z is initialized to the unit matrix and the matrix Z
+*                 of right Schur vectors of (H,T) is returned;
+*          = 'V': Z must contain an orthogonal matrix Z1 on entry and
+*                 the product Z1*Z is returned.
+*
+*  N       (input) INTEGER
+*          The order of the matrices H, T, Q, and Z.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI mark the rows and columns of H which are in
+*          Hessenberg form.  It is assumed that A is already upper
+*          triangular in rows and columns 1:ILO-1 and IHI+1:N.
+*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
+*
+*  H       (input/output) DOUBLE PRECISION array, dimension (LDH, N)
+*          On entry, the N-by-N upper Hessenberg matrix H.
+*          On exit, if JOB = 'S', H contains the upper quasi-triangular
+*          matrix S from the generalized Schur factorization;
+*          2-by-2 diagonal blocks (corresponding to complex conjugate
+*          pairs of eigenvalues) are returned in standard form, with
+*          H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
+*          If JOB = 'E', the diagonal blocks of H match those of S, but
+*          the rest of H is unspecified.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max( 1, N ).
+*
+*  T       (input/output) DOUBLE PRECISION array, dimension (LDT, N)
+*          On entry, the N-by-N upper triangular matrix T.
+*          On exit, if JOB = 'S', T contains the upper triangular
+*          matrix P from the generalized Schur factorization;
+*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
+*          are reduced to positive diagonal form, i.e., if H(j+1,j) is
+*          non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
+*          T(j+1,j+1) > 0.
+*          If JOB = 'E', the diagonal blocks of T match those of P, but
+*          the rest of T is unspecified.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= max( 1, N ).
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
+*          The real parts of each scalar alpha defining an eigenvalue
+*          of GNEP.
+*
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
+*          The imaginary parts of each scalar alpha defining an
+*          eigenvalue of GNEP.
+*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+*          positive, then the j-th and (j+1)-st eigenvalues are a
+*          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
+*
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          The scalars beta that define the eigenvalues of GNEP.
+*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+*          beta = BETA(j) represent the j-th eigenvalue of the matrix
+*          pair (A,B), in one of the forms lambda = alpha/beta or
+*          mu = beta/alpha.  Since either lambda or mu may overflow,
+*          they should not, in general, be computed.
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+*          On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
+*          the reduction of (A,B) to generalized Hessenberg form.
+*          On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
+*          vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
+*          of left Schur vectors of (A,B).
+*          Not referenced if COMPZ = 'N'.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= 1.
+*          If COMPQ='V' or 'I', then LDQ >= N.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
+*          the reduction of (A,B) to generalized Hessenberg form.
+*          On exit, if COMPZ = 'I', the orthogonal matrix of
+*          right Schur vectors of (H,T), and if COMPZ = 'V', the
+*          orthogonal matrix of right Schur vectors of (A,B).
+*          Not referenced if COMPZ = 'N'.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1.
+*          If COMPZ='V' or 'I', then LDZ >= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not
+*                     in Schur form, but ALPHAR(i), ALPHAI(i), and
+*                     BETA(i), i=INFO+1,...,N should be correct.
+*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not
+*                     in Schur form, but ALPHAR(i), ALPHAI(i), and
+*                     BETA(i), i=INFO-N+1,...,N should be correct.
+*
+*  Further Details
+*  ===============
+*
+*  Iteration counters:
+*
+*  JITER  -- counts iterations.
+*  IITER  -- counts iterations run since ILAST was last
+*            changed.  This is therefore reset only when a 1-by-1 or
+*            2-by-2 block deflates off the bottom.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+*    $                     SAFETY = 1.0E+0 )
+      DOUBLE PRECISION   HALF, ZERO, ONE, SAFETY
+      PARAMETER          ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,
+     $                   SAFETY = 1.0D+2 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
+     $                   LQUERY
+      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
+     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
+     $                   JR, MAXIT
+      DOUBLE PRECISION   A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
+     $                   AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
+     $                   AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
+     $                   B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
+     $                   BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
+     $                   CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
+     $                   SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
+     $                   TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
+     $                   U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
+     $                   WR2
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   V( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANHS, DLAPY2, DLAPY3
+      EXTERNAL           LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode JOB, COMPQ, COMPZ
+*
+      IF( LSAME( JOB, 'E' ) ) THEN
+         ILSCHR = .FALSE.
+         ISCHUR = 1
+      ELSE IF( LSAME( JOB, 'S' ) ) THEN
+         ILSCHR = .TRUE.
+         ISCHUR = 2
+      ELSE
+         ISCHUR = 0
+      END IF
+*
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ILQ = .FALSE.
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 2
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 3
+      ELSE
+         ICOMPQ = 0
+      END IF
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ILZ = .FALSE.
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 2
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 3
+      ELSE
+         ICOMPZ = 0
+      END IF
+*
+*     Check Argument Values
+*
+      INFO = 0
+      WORK( 1 ) = MAX( 1, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( ISCHUR.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPQ.EQ.0 ) THEN
+         INFO = -2
+      ELSE IF( ICOMPZ.EQ.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+         INFO = -6
+      ELSE IF( LDH.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDT.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -15
+      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -17
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -19
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DHGEQZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = DBLE( 1 )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+*     Machine Constants
+*
+      IN = IHI + 1 - ILO
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
+      ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
+      BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK )
+      ATOL = MAX( SAFMIN, ULP*ANORM )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+      ASCALE = ONE / MAX( SAFMIN, ANORM )
+      BSCALE = ONE / MAX( SAFMIN, BNORM )
+*
+*     Set Eigenvalues IHI+1:N
+*
+      DO 30 J = IHI + 1, N
+         IF( T( J, J ).LT.ZERO ) THEN
+            IF( ILSCHR ) THEN
+               DO 10 JR = 1, J
+                  H( JR, J ) = -H( JR, J )
+                  T( JR, J ) = -T( JR, J )
+   10          CONTINUE
+            ELSE
+               H( J, J ) = -H( J, J )
+               T( J, J ) = -T( J, J )
+            END IF
+            IF( ILZ ) THEN
+               DO 20 JR = 1, N
+                  Z( JR, J ) = -Z( JR, J )
+   20          CONTINUE
+            END IF
+         END IF
+         ALPHAR( J ) = H( J, J )
+         ALPHAI( J ) = ZERO
+         BETA( J ) = T( J, J )
+   30 CONTINUE
+*
+*     If IHI < ILO, skip QZ steps
+*
+      IF( IHI.LT.ILO )
+     $   GO TO 380
+*
+*     MAIN QZ ITERATION LOOP
+*
+*     Initialize dynamic indices
+*
+*     Eigenvalues ILAST+1:N have been found.
+*        Column operations modify rows IFRSTM:whatever.
+*        Row operations modify columns whatever:ILASTM.
+*
+*     If only eigenvalues are being computed, then
+*        IFRSTM is the row of the last splitting row above row ILAST;
+*        this is always at least ILO.
+*     IITER counts iterations since the last eigenvalue was found,
+*        to tell when to use an extraordinary shift.
+*     MAXIT is the maximum number of QZ sweeps allowed.
+*
+      ILAST = IHI
+      IF( ILSCHR ) THEN
+         IFRSTM = 1
+         ILASTM = N
+      ELSE
+         IFRSTM = ILO
+         ILASTM = IHI
+      END IF
+      IITER = 0
+      ESHIFT = ZERO
+      MAXIT = 30*( IHI-ILO+1 )
+*
+      DO 360 JITER = 1, MAXIT
+*
+*        Split the matrix if possible.
+*
+*        Two tests:
+*           1: H(j,j-1)=0  or  j=ILO
+*           2: T(j,j)=0
+*
+         IF( ILAST.EQ.ILO ) THEN
+*
+*           Special case: j=ILAST
+*
+            GO TO 80
+         ELSE
+            IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
+               H( ILAST, ILAST-1 ) = ZERO
+               GO TO 80
+            END IF
+         END IF
+*
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
+            T( ILAST, ILAST ) = ZERO
+            GO TO 70
+         END IF
+*
+*        General case: j<ILAST
+*
+         DO 60 J = ILAST - 1, ILO, -1
+*
+*           Test 1: for H(j,j-1)=0 or j=ILO
+*
+            IF( J.EQ.ILO ) THEN
+               ILAZRO = .TRUE.
+            ELSE
+               IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN
+                  H( J, J-1 ) = ZERO
+                  ILAZRO = .TRUE.
+               ELSE
+                  ILAZRO = .FALSE.
+               END IF
+            END IF
+*
+*           Test 2: for T(j,j)=0
+*
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
+               T( J, J ) = ZERO
+*
+*              Test 1a: Check for 2 consecutive small subdiagonals in A
+*
+               ILAZR2 = .FALSE.
+               IF( .NOT.ILAZRO ) THEN
+                  TEMP = ABS( H( J, J-1 ) )
+                  TEMP2 = ABS( H( J, J ) )
+                  TEMPR = MAX( TEMP, TEMP2 )
+                  IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+                     TEMP = TEMP / TEMPR
+                     TEMP2 = TEMP2 / TEMPR
+                  END IF
+                  IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2*
+     $                ( ASCALE*ATOL ) )ILAZR2 = .TRUE.
+               END IF
+*
+*              If both tests pass (1 & 2), i.e., the leading diagonal
+*              element of B in the block is zero, split a 1x1 block off
+*              at the top. (I.e., at the J-th row/column) The leading
+*              diagonal element of the remainder can also be zero, so
+*              this may have to be done repeatedly.
+*
+               IF( ILAZRO .OR. ILAZR2 ) THEN
+                  DO 40 JCH = J, ILAST - 1
+                     TEMP = H( JCH, JCH )
+                     CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S,
+     $                            H( JCH, JCH ) )
+                     H( JCH+1, JCH ) = ZERO
+                     CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+     $                          H( JCH+1, JCH+1 ), LDH, C, S )
+                     CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+     $                          T( JCH+1, JCH+1 ), LDT, C, S )
+                     IF( ILQ )
+     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, S )
+                     IF( ILAZR2 )
+     $                  H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
+                     ILAZR2 = .FALSE.
+                     IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
+                        IF( JCH+1.GE.ILAST ) THEN
+                           GO TO 80
+                        ELSE
+                           IFIRST = JCH + 1
+                           GO TO 110
+                        END IF
+                     END IF
+                     T( JCH+1, JCH+1 ) = ZERO
+   40             CONTINUE
+                  GO TO 70
+               ELSE
+*
+*                 Only test 2 passed -- chase the zero to T(ILAST,ILAST)
+*                 Then process as in the case T(ILAST,ILAST)=0
+*
+                  DO 50 JCH = J, ILAST - 1
+                     TEMP = T( JCH, JCH+1 )
+                     CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S,
+     $                            T( JCH, JCH+1 ) )
+                     T( JCH+1, JCH+1 ) = ZERO
+                     IF( JCH.LT.ILASTM-1 )
+     $                  CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+     $                             T( JCH+1, JCH+2 ), LDT, C, S )
+                     CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+     $                          H( JCH+1, JCH-1 ), LDH, C, S )
+                     IF( ILQ )
+     $                  CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, S )
+                     TEMP = H( JCH+1, JCH )
+                     CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S,
+     $                            H( JCH+1, JCH ) )
+                     H( JCH+1, JCH-1 ) = ZERO
+                     CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+     $                          H( IFRSTM, JCH-1 ), 1, C, S )
+                     CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+     $                          T( IFRSTM, JCH-1 ), 1, C, S )
+                     IF( ILZ )
+     $                  CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
+     $                             C, S )
+   50             CONTINUE
+                  GO TO 70
+               END IF
+            ELSE IF( ILAZRO ) THEN
+*
+*              Only test 1 passed -- work on J:ILAST
+*
+               IFIRST = J
+               GO TO 110
+            END IF
+*
+*           Neither test passed -- try next J
+*
+   60    CONTINUE
+*
+*        (Drop-through is "impossible")
+*
+         INFO = N + 1
+         GO TO 420
+*
+*        T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
+*        1x1 block.
+*
+   70    CONTINUE
+         TEMP = H( ILAST, ILAST )
+         CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S,
+     $                H( ILAST, ILAST ) )
+         H( ILAST, ILAST-1 ) = ZERO
+         CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+     $              H( IFRSTM, ILAST-1 ), 1, C, S )
+         CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+     $              T( IFRSTM, ILAST-1 ), 1, C, S )
+         IF( ILZ )
+     $      CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
+*
+*        H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
+*                              and BETA
+*
+   80    CONTINUE
+         IF( T( ILAST, ILAST ).LT.ZERO ) THEN
+            IF( ILSCHR ) THEN
+               DO 90 J = IFRSTM, ILAST
+                  H( J, ILAST ) = -H( J, ILAST )
+                  T( J, ILAST ) = -T( J, ILAST )
+   90          CONTINUE
+            ELSE
+               H( ILAST, ILAST ) = -H( ILAST, ILAST )
+               T( ILAST, ILAST ) = -T( ILAST, ILAST )
+            END IF
+            IF( ILZ ) THEN
+               DO 100 J = 1, N
+                  Z( J, ILAST ) = -Z( J, ILAST )
+  100          CONTINUE
+            END IF
+         END IF
+         ALPHAR( ILAST ) = H( ILAST, ILAST )
+         ALPHAI( ILAST ) = ZERO
+         BETA( ILAST ) = T( ILAST, ILAST )
+*
+*        Go to next block -- exit if finished.
+*
+         ILAST = ILAST - 1
+         IF( ILAST.LT.ILO )
+     $      GO TO 380
+*
+*        Reset counters
+*
+         IITER = 0
+         ESHIFT = ZERO
+         IF( .NOT.ILSCHR ) THEN
+            ILASTM = ILAST
+            IF( IFRSTM.GT.ILAST )
+     $         IFRSTM = ILO
+         END IF
+         GO TO 350
+*
+*        QZ step
+*
+*        This iteration only involves rows/columns IFIRST:ILAST. We
+*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
+*
+  110    CONTINUE
+         IITER = IITER + 1
+         IF( .NOT.ILSCHR ) THEN
+            IFRSTM = IFIRST
+         END IF
+*
+*        Compute single shifts.
+*
+*        At this point, IFIRST < ILAST, and the diagonal elements of
+*        T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
+*        magnitude)
+*
+         IF( ( IITER / 10 )*10.EQ.IITER ) THEN
+*
+*           Exceptional shift.  Chosen for no particularly good reason.
+*           (Single shift only.)
+*
+            IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
+     $          ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
+               ESHIFT = ESHIFT + H( ILAST-1, ILAST ) /
+     $                  T( ILAST-1, ILAST-1 )
+            ELSE
+               ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
+            END IF
+            S1 = ONE
+            WR = ESHIFT
+*
+         ELSE
+*
+*           Shifts based on the generalized eigenvalues of the
+*           bottom-right 2x2 block of A and B. The first eigenvalue
+*           returned by DLAG2 is the Wilkinson shift (AEP p.512),
+*
+            CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH,
+     $                  T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+     $                  S2, WR, WR2, WI )
+*
+            TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
+            IF( WI.NE.ZERO )
+     $         GO TO 200
+         END IF
+*
+*        Fiddle with shift to avoid overflow
+*
+         TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )
+         IF( S1.GT.TEMP ) THEN
+            SCALE = TEMP / S1
+         ELSE
+            SCALE = ONE
+         END IF
+*
+         TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )
+         IF( ABS( WR ).GT.TEMP )
+     $      SCALE = MIN( SCALE, TEMP / ABS( WR ) )
+         S1 = SCALE*S1
+         WR = SCALE*WR
+*
+*        Now check for two consecutive small subdiagonals.
+*
+         DO 120 J = ILAST - 1, IFIRST + 1, -1
+            ISTART = J
+            TEMP = ABS( S1*H( J, J-1 ) )
+            TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) )
+            TEMPR = MAX( TEMP, TEMP2 )
+            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+               TEMP = TEMP / TEMPR
+               TEMP2 = TEMP2 / TEMPR
+            END IF
+            IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )*
+     $          TEMP2 )GO TO 130
+  120    CONTINUE
+*
+         ISTART = IFIRST
+  130    CONTINUE
+*
+*        Do an implicit single-shift QZ sweep.
+*
+*        Initial Q
+*
+         TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART )
+         TEMP2 = S1*H( ISTART+1, ISTART )
+         CALL DLARTG( TEMP, TEMP2, C, S, TEMPR )
+*
+*        Sweep
+*
+         DO 190 J = ISTART, ILAST - 1
+            IF( J.GT.ISTART ) THEN
+               TEMP = H( J, J-1 )
+               CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+               H( J+1, J-1 ) = ZERO
+            END IF
+*
+            DO 140 JC = J, ILASTM
+               TEMP = C*H( J, JC ) + S*H( J+1, JC )
+               H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+               H( J, JC ) = TEMP
+               TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+               T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+               T( J, JC ) = TEMP2
+  140       CONTINUE
+            IF( ILQ ) THEN
+               DO 150 JR = 1, N
+                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+                  Q( JR, J ) = TEMP
+  150          CONTINUE
+            END IF
+*
+            TEMP = T( J+1, J+1 )
+            CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+            T( J+1, J ) = ZERO
+*
+            DO 160 JR = IFRSTM, MIN( J+2, ILAST )
+               TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+               H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+               H( JR, J+1 ) = TEMP
+  160       CONTINUE
+            DO 170 JR = IFRSTM, J
+               TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+               T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+               T( JR, J+1 ) = TEMP
+  170       CONTINUE
+            IF( ILZ ) THEN
+               DO 180 JR = 1, N
+                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+                  Z( JR, J+1 ) = TEMP
+  180          CONTINUE
+            END IF
+  190    CONTINUE
+*
+         GO TO 350
+*
+*        Use Francis double-shift
+*
+*        Note: the Francis double-shift should work with real shifts,
+*              but only if the block is at least 3x3.
+*              This code may break if this point is reached with
+*              a 2x2 block with real eigenvalues.
+*
+  200    CONTINUE
+         IF( IFIRST+1.EQ.ILAST ) THEN
+*
+*           Special case -- 2x2 block with complex eigenvectors
+*
+*           Step 1: Standardize, that is, rotate so that
+*
+*                       ( B11  0  )
+*                   B = (         )  with B11 non-negative.
+*                       (  0  B22 )
+*
+            CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ),
+     $                   T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )
+*
+            IF( B11.LT.ZERO ) THEN
+               CR = -CR
+               SR = -SR
+               B11 = -B11
+               B22 = -B22
+            END IF
+*
+            CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH,
+     $                 H( ILAST, ILAST-1 ), LDH, CL, SL )
+            CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1,
+     $                 H( IFRSTM, ILAST ), 1, CR, SR )
+*
+            IF( ILAST.LT.ILASTM )
+     $         CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT,
+     $                    T( ILAST, ILAST+1 ), LDH, CL, SL )
+            IF( IFRSTM.LT.ILAST-1 )
+     $         CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1,
+     $                    T( IFRSTM, ILAST ), 1, CR, SR )
+*
+            IF( ILQ )
+     $         CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,
+     $                    SL )
+            IF( ILZ )
+     $         CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR,
+     $                    SR )
+*
+            T( ILAST-1, ILAST-1 ) = B11
+            T( ILAST-1, ILAST ) = ZERO
+            T( ILAST, ILAST-1 ) = ZERO
+            T( ILAST, ILAST ) = B22
+*
+*           If B22 is negative, negate column ILAST
+*
+            IF( B22.LT.ZERO ) THEN
+               DO 210 J = IFRSTM, ILAST
+                  H( J, ILAST ) = -H( J, ILAST )
+                  T( J, ILAST ) = -T( J, ILAST )
+  210          CONTINUE
+*
+               IF( ILZ ) THEN
+                  DO 220 J = 1, N
+                     Z( J, ILAST ) = -Z( J, ILAST )
+  220             CONTINUE
+               END IF
+            END IF
+*
+*           Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
+*
+*           Recompute shift
+*
+            CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH,
+     $                  T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+     $                  TEMP, WR, TEMP2, WI )
+*
+*           If standardization has perturbed the shift onto real line,
+*           do another (real single-shift) QR step.
+*
+            IF( WI.EQ.ZERO )
+     $         GO TO 350
+            S1INV = ONE / S1
+*
+*           Do EISPACK (QZVAL) computation of alpha and beta
+*
+            A11 = H( ILAST-1, ILAST-1 )
+            A21 = H( ILAST, ILAST-1 )
+            A12 = H( ILAST-1, ILAST )
+            A22 = H( ILAST, ILAST )
+*
+*           Compute complex Givens rotation on right
+*           (Assume some element of C = (sA - wB) > unfl )
+*                            __
+*           (sA - wB) ( CZ   -SZ )
+*                     ( SZ    CZ )
+*
+            C11R = S1*A11 - WR*B11
+            C11I = -WI*B11
+            C12 = S1*A12
+            C21 = S1*A21
+            C22R = S1*A22 - WR*B22
+            C22I = -WI*B22
+*
+            IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
+     $          ABS( C22R )+ABS( C22I ) ) THEN
+               T1 = DLAPY3( C12, C11R, C11I )
+               CZ = C12 / T1
+               SZR = -C11R / T1
+               SZI = -C11I / T1
+            ELSE
+               CZ = DLAPY2( C22R, C22I )
+               IF( CZ.LE.SAFMIN ) THEN
+                  CZ = ZERO
+                  SZR = ONE
+                  SZI = ZERO
+               ELSE
+                  TEMPR = C22R / CZ
+                  TEMPI = C22I / CZ
+                  T1 = DLAPY2( CZ, C21 )
+                  CZ = CZ / T1
+                  SZR = -C21*TEMPR / T1
+                  SZI = C21*TEMPI / T1
+               END IF
+            END IF
+*
+*           Compute Givens rotation on left
+*
+*           (  CQ   SQ )
+*           (  __      )  A or B
+*           ( -SQ   CQ )
+*
+            AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
+            BN = ABS( B11 ) + ABS( B22 )
+            WABS = ABS( WR ) + ABS( WI )
+            IF( S1*AN.GT.WABS*BN ) THEN
+               CQ = CZ*B11
+               SQR = SZR*B22
+               SQI = -SZI*B22
+            ELSE
+               A1R = CZ*A11 + SZR*A12
+               A1I = SZI*A12
+               A2R = CZ*A21 + SZR*A22
+               A2I = SZI*A22
+               CQ = DLAPY2( A1R, A1I )
+               IF( CQ.LE.SAFMIN ) THEN
+                  CQ = ZERO
+                  SQR = ONE
+                  SQI = ZERO
+               ELSE
+                  TEMPR = A1R / CQ
+                  TEMPI = A1I / CQ
+                  SQR = TEMPR*A2R + TEMPI*A2I
+                  SQI = TEMPI*A2R - TEMPR*A2I
+               END IF
+            END IF
+            T1 = DLAPY3( CQ, SQR, SQI )
+            CQ = CQ / T1
+            SQR = SQR / T1
+            SQI = SQI / T1
+*
+*           Compute diagonal elements of QBZ
+*
+            TEMPR = SQR*SZR - SQI*SZI
+            TEMPI = SQR*SZI + SQI*SZR
+            B1R = CQ*CZ*B11 + TEMPR*B22
+            B1I = TEMPI*B22
+            B1A = DLAPY2( B1R, B1I )
+            B2R = CQ*CZ*B22 + TEMPR*B11
+            B2I = -TEMPI*B11
+            B2A = DLAPY2( B2R, B2I )
+*
+*           Normalize so beta > 0, and Im( alpha1 ) > 0
+*
+            BETA( ILAST-1 ) = B1A
+            BETA( ILAST ) = B2A
+            ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
+            ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
+            ALPHAR( ILAST ) = ( WR*B2A )*S1INV
+            ALPHAI( ILAST ) = -( WI*B2A )*S1INV
+*
+*           Step 3: Go to next block -- exit if finished.
+*
+            ILAST = IFIRST - 1
+            IF( ILAST.LT.ILO )
+     $         GO TO 380
+*
+*           Reset counters
+*
+            IITER = 0
+            ESHIFT = ZERO
+            IF( .NOT.ILSCHR ) THEN
+               ILASTM = ILAST
+               IF( IFRSTM.GT.ILAST )
+     $            IFRSTM = ILO
+            END IF
+            GO TO 350
+         ELSE
+*
+*           Usual case: 3x3 or larger block, using Francis implicit
+*                       double-shift
+*
+*                                    2
+*           Eigenvalue equation is  w  - c w + d = 0,
+*
+*                                         -1 2        -1
+*           so compute 1st column of  (A B  )  - c A B   + d
+*           using the formula in QZIT (from EISPACK)
+*
+*           We assume that the block is at least 3x3
+*
+            AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
+     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
+            AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
+     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
+            AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
+     $             ( BSCALE*T( ILAST, ILAST ) )
+            AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
+     $             ( BSCALE*T( ILAST, ILAST ) )
+            U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST )
+            AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) /
+     $              ( BSCALE*T( IFIRST, IFIRST ) )
+            AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) /
+     $              ( BSCALE*T( IFIRST, IFIRST ) )
+            AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) /
+     $              ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+            AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) /
+     $              ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+            AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) /
+     $              ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+            U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 )
+*
+            V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
+     $               AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
+            V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
+     $               ( AD22-AD11L )+AD21*U12 )*AD21L
+            V( 3 ) = AD32L*AD21L
+*
+            ISTART = IFIRST
+*
+            CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
+            V( 1 ) = ONE
+*
+*           Sweep
+*
+            DO 290 J = ISTART, ILAST - 2
+*
+*              All but last elements: use 3x3 Householder transforms.
+*
+*              Zero (j-1)st column of A
+*
+               IF( J.GT.ISTART ) THEN
+                  V( 1 ) = H( J, J-1 )
+                  V( 2 ) = H( J+1, J-1 )
+                  V( 3 ) = H( J+2, J-1 )
+*
+                  CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU )
+                  V( 1 ) = ONE
+                  H( J+1, J-1 ) = ZERO
+                  H( J+2, J-1 ) = ZERO
+               END IF
+*
+               DO 230 JC = J, ILASTM
+                  TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
+     $                   H( J+2, JC ) )
+                  H( J, JC ) = H( J, JC ) - TEMP
+                  H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
+                  H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
+                  TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
+     $                    T( J+2, JC ) )
+                  T( J, JC ) = T( J, JC ) - TEMP2
+                  T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
+                  T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
+  230          CONTINUE
+               IF( ILQ ) THEN
+                  DO 240 JR = 1, N
+                     TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
+     $                      Q( JR, J+2 ) )
+                     Q( JR, J ) = Q( JR, J ) - TEMP
+                     Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
+                     Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
+  240             CONTINUE
+               END IF
+*
+*              Zero j-th column of B (see DLAGBC for details)
+*
+*              Swap rows to pivot
+*
+               ILPIVT = .FALSE.
+               TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) )
+               TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) )
+               IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
+                  SCALE = ZERO
+                  U1 = ONE
+                  U2 = ZERO
+                  GO TO 250
+               ELSE IF( TEMP.GE.TEMP2 ) THEN
+                  W11 = T( J+1, J+1 )
+                  W21 = T( J+2, J+1 )
+                  W12 = T( J+1, J+2 )
+                  W22 = T( J+2, J+2 )
+                  U1 = T( J+1, J )
+                  U2 = T( J+2, J )
+               ELSE
+                  W21 = T( J+1, J+1 )
+                  W11 = T( J+2, J+1 )
+                  W22 = T( J+1, J+2 )
+                  W12 = T( J+2, J+2 )
+                  U2 = T( J+1, J )
+                  U1 = T( J+2, J )
+               END IF
+*
+*              Swap columns if nec.
+*
+               IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
+                  ILPIVT = .TRUE.
+                  TEMP = W12
+                  TEMP2 = W22
+                  W12 = W11
+                  W22 = W21
+                  W11 = TEMP
+                  W21 = TEMP2
+               END IF
+*
+*              LU-factor
+*
+               TEMP = W21 / W11
+               U2 = U2 - TEMP*U1
+               W22 = W22 - TEMP*W12
+               W21 = ZERO
+*
+*              Compute SCALE
+*
+               SCALE = ONE
+               IF( ABS( W22 ).LT.SAFMIN ) THEN
+                  SCALE = ZERO
+                  U2 = ONE
+                  U1 = -W12 / W11
+                  GO TO 250
+               END IF
+               IF( ABS( W22 ).LT.ABS( U2 ) )
+     $            SCALE = ABS( W22 / U2 )
+               IF( ABS( W11 ).LT.ABS( U1 ) )
+     $            SCALE = MIN( SCALE, ABS( W11 / U1 ) )
+*
+*              Solve
+*
+               U2 = ( SCALE*U2 ) / W22
+               U1 = ( SCALE*U1-W12*U2 ) / W11
+*
+  250          CONTINUE
+               IF( ILPIVT ) THEN
+                  TEMP = U2
+                  U2 = U1
+                  U1 = TEMP
+               END IF
+*
+*              Compute Householder Vector
+*
+               T1 = SQRT( SCALE**2+U1**2+U2**2 )
+               TAU = ONE + SCALE / T1
+               VS = -ONE / ( SCALE+T1 )
+               V( 1 ) = ONE
+               V( 2 ) = VS*U1
+               V( 3 ) = VS*U2
+*
+*              Apply transformations from the right.
+*
+               DO 260 JR = IFRSTM, MIN( J+3, ILAST )
+                  TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
+     $                   H( JR, J+2 ) )
+                  H( JR, J ) = H( JR, J ) - TEMP
+                  H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
+                  H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
+  260          CONTINUE
+               DO 270 JR = IFRSTM, J + 2
+                  TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
+     $                   T( JR, J+2 ) )
+                  T( JR, J ) = T( JR, J ) - TEMP
+                  T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
+                  T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
+  270          CONTINUE
+               IF( ILZ ) THEN
+                  DO 280 JR = 1, N
+                     TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
+     $                      Z( JR, J+2 ) )
+                     Z( JR, J ) = Z( JR, J ) - TEMP
+                     Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
+                     Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
+  280             CONTINUE
+               END IF
+               T( J+1, J ) = ZERO
+               T( J+2, J ) = ZERO
+  290       CONTINUE
+*
+*           Last elements: Use Givens rotations
+*
+*           Rotations from the left
+*
+            J = ILAST - 1
+            TEMP = H( J, J-1 )
+            CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+            H( J+1, J-1 ) = ZERO
+*
+            DO 300 JC = J, ILASTM
+               TEMP = C*H( J, JC ) + S*H( J+1, JC )
+               H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+               H( J, JC ) = TEMP
+               TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+               T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+               T( J, JC ) = TEMP2
+  300       CONTINUE
+            IF( ILQ ) THEN
+               DO 310 JR = 1, N
+                  TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+                  Q( JR, J ) = TEMP
+  310          CONTINUE
+            END IF
+*
+*           Rotations from the right.
+*
+            TEMP = T( J+1, J+1 )
+            CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+            T( J+1, J ) = ZERO
+*
+            DO 320 JR = IFRSTM, ILAST
+               TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+               H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+               H( JR, J+1 ) = TEMP
+  320       CONTINUE
+            DO 330 JR = IFRSTM, ILAST - 1
+               TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+               T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+               T( JR, J+1 ) = TEMP
+  330       CONTINUE
+            IF( ILZ ) THEN
+               DO 340 JR = 1, N
+                  TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+                  Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+                  Z( JR, J+1 ) = TEMP
+  340          CONTINUE
+            END IF
+*
+*           End of Double-Shift code
+*
+         END IF
+*
+         GO TO 350
+*
+*        End of iteration loop
+*
+  350    CONTINUE
+  360 CONTINUE
+*
+*     Drop-through = non-convergence
+*
+      INFO = ILAST
+      GO TO 420
+*
+*     Successful completion of all QZ steps
+*
+  380 CONTINUE
+*
+*     Set Eigenvalues 1:ILO-1
+*
+      DO 410 J = 1, ILO - 1
+         IF( T( J, J ).LT.ZERO ) THEN
+            IF( ILSCHR ) THEN
+               DO 390 JR = 1, J
+                  H( JR, J ) = -H( JR, J )
+                  T( JR, J ) = -T( JR, J )
+  390          CONTINUE
+            ELSE
+               H( J, J ) = -H( J, J )
+               T( J, J ) = -T( J, J )
+            END IF
+            IF( ILZ ) THEN
+               DO 400 JR = 1, N
+                  Z( JR, J ) = -Z( JR, J )
+  400          CONTINUE
+            END IF
+         END IF
+         ALPHAR( J ) = H( J, J )
+         ALPHAI( J ) = ZERO
+         BETA( J ) = T( J, J )
+  410 CONTINUE
+*
+*     Normal Termination
+*
+      INFO = 0
+*
+*     Exit (other than argument error) -- return optimal workspace size
+*
+  420 CONTINUE
+      WORK( 1 ) = DBLE( N )
+      RETURN
+*
+*     End of DHGEQZ
+*
+      END
diff --git a/src/lib/lapack/dhseqr.f b/src/lib/lapack/dhseqr.f
new file mode 100644
index 00000000..5b307fa8
--- /dev/null
+++ b/src/lib/lapack/dhseqr.f
@@ -0,0 +1,407 @@
+      SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
+     $                   LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
+      CHARACTER          COMPZ, JOB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*     Purpose
+*     =======
+*
+*     DHSEQR computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+*     Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input orthogonal
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+*     Arguments
+*     =========
+*
+*     JOB   (input) CHARACTER*1
+*           = 'E':  compute eigenvalues only;
+*           = 'S':  compute eigenvalues and the Schur form T.
+*
+*     COMPZ (input) CHARACTER*1
+*           = 'N':  no Schur vectors are computed;
+*           = 'I':  Z is initialized to the unit matrix and the matrix Z
+*                   of Schur vectors of H is returned;
+*           = 'V':  Z must contain an orthogonal matrix Q on entry, and
+*                   the product Q*Z is returned.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*           set by a previous call to DGEBAL, and then passed to DGEHRD
+*           when the matrix output by DGEBAL is reduced to Hessenberg
+*           form. Otherwise ILO and IHI should be set to 1 and N
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and JOB = 'S', then H contains the
+*           upper quasi-triangular matrix T from the Schur decomposition
+*           (the Schur form); 2-by-2 diagonal blocks (corresponding to
+*           complex conjugate pairs of eigenvalues) are returned in
+*           standard form, with H(i,i) = H(i+1,i+1) and
+*           H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
+*           contents of H are unspecified on exit.  (The output value of
+*           H when INFO.GT.0 is given under the description of INFO
+*           below.)
+*
+*           Unlike earlier versions of DHSEQR, this subroutine may
+*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+*           or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     WR    (output) DOUBLE PRECISION array, dimension (N)
+*     WI    (output) DOUBLE PRECISION array, dimension (N)
+*           The real and imaginary parts, respectively, of the computed
+*           eigenvalues. If two eigenvalues are computed as a complex
+*           conjugate pair, they are stored in consecutive elements of
+*           WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
+*           WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
+*           the same order as on the diagonal of the Schur form returned
+*           in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
+*           diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+*           WI(i+1) = -WI(i).
+*
+*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*           If COMPZ = 'N', Z is not referenced.
+*           If COMPZ = 'I', on entry Z need not be set and on exit,
+*           if INFO = 0, Z contains the orthogonal matrix Z of the Schur
+*           vectors of H.  If COMPZ = 'V', on entry Z must contain an
+*           N-by-N matrix Q, which is assumed to be equal to the unit
+*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+*           if INFO = 0, Z contains Q*Z.
+*           Normally Q is the orthogonal matrix generated by DORGHR
+*           after the call to DGEHRD which formed the Hessenberg matrix
+*           H. (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if COMPZ = 'I' or
+*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+*           On exit, if INFO = 0, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then DHSEQR does a workspace query.
+*           In this case, DHSEQR checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .LT. 0:  if INFO = -i, the i-th argument had an illegal
+*                    value
+*           .GT. 0:  if INFO = i, DHSEQR failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and JOB = 'E', then on exit, the
+*                remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and JOB   = 'S', then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is an orthogonal matrix.  The final
+*                value of H is upper Hessenberg and quasi-triangular
+*                in rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and COMPZ = 'V', then on exit
+*
+*                  (final value of Z)  =  (initial value of Z)*U
+*
+*                where U is the orthogonal matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'I', then on exit
+*                      (final value of Z)  = U
+*                where U is the orthogonal matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'N', then Z is not
+*                accessed.
+*
+*     ================================================================
+*             Default values supplied by
+*             ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+*             It is suggested that these defaults be adjusted in order
+*             to attain best performance in each particular
+*             computational environment.
+*
+*            ISPEC=1:  The DLAHQR vs DLAQR0 crossover point.
+*                      Default: 75. (Must be at least 11.)
+*
+*            ISPEC=2:  Recommended deflation window size.
+*                      This depends on ILO, IHI and NS.  NS is the
+*                      number of simultaneous shifts returned
+*                      by ILAENV(ISPEC=4).  (See ISPEC=4 below.)
+*                      The default for (IHI-ILO+1).LE.500 is NS.
+*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+*            ISPEC=3:  Nibble crossover point. (See ILAENV for
+*                      details.)  Default: 14% of deflation window
+*                      size.
+*
+*            ISPEC=4:  Number of simultaneous shifts, NS, in
+*                      a multi-shift QR iteration.
+*
+*                      If IHI-ILO+1 is ...
+*
+*                      greater than      ...but less    ... the
+*                      or equal to ...      than        default is
+*
+*                           1               30          NS -   2(+)
+*                          30               60          NS -   4(+)
+*                          60              150          NS =  10(+)
+*                         150              590          NS =  **
+*                         590             3000          NS =  64
+*                        3000             6000          NS = 128
+*                        6000             infinity      NS = 256
+*
+*                  (+)  By default some or all matrices of this order 
+*                       are passed to the implicit double shift routine
+*                       DLAHQR and NS is ignored.  See ISPEC=1 above 
+*                       and comments in IPARM for details.
+*
+*                       The asterisks (**) indicate an ad-hoc
+*                       function of N increasing from 10 to 64.
+*
+*            ISPEC=5:  Select structured matrix multiply.
+*                      (See ILAENV for details.) Default: 3.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    DLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== NL allocates some local workspace to help small matrices
+*     .    through a rare DLAHQR failure.  NL .GT. NTINY = 11 is
+*     .    required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
+*     .    mended.  (The default value of NMIN is 75.)  Using NL = 49
+*     .    allows up to six simultaneous shifts and a 16-by-16
+*     .    deflation window.  ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            NL
+      PARAMETER          ( NL = 49 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   HL( NL, NL ), WORKL( NL )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, KBOT, NMIN
+      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      LOGICAL            LSAME
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Decode and check the input parameters. ====
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+      WORK( 1 ) = DBLE( MAX( 1, N ) )
+      LQUERY = LWORK.EQ.-1
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -11
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -13
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+*
+*        ==== Quick return in case of invalid argument. ====
+*
+         CALL XERBLA( 'DHSEQR', -INFO )
+         RETURN
+*
+      ELSE IF( N.EQ.0 ) THEN
+*
+*        ==== Quick return in case N = 0; nothing to do. ====
+*
+         RETURN
+*
+      ELSE IF( LQUERY ) THEN
+*
+*        ==== Quick return in case of a workspace query ====
+*
+         CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                IHI, Z, LDZ, WORK, LWORK, INFO )
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+         WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
+         RETURN
+*
+      ELSE
+*
+*        ==== copy eigenvalues isolated by DGEBAL ====
+*
+         DO 10 I = 1, ILO - 1
+            WR( I ) = H( I, I )
+            WI( I ) = ZERO
+   10    CONTINUE
+         DO 20 I = IHI + 1, N
+            WR( I ) = H( I, I )
+            WI( I ) = ZERO
+   20    CONTINUE
+*
+*        ==== Initialize Z, if requested ====
+*
+         IF( INITZ )
+     $      CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+*        ==== Quick return if possible ====
+*
+         IF( ILO.EQ.IHI ) THEN
+            WR( ILO ) = H( ILO, ILO )
+            WI( ILO ) = ZERO
+            RETURN
+         END IF
+*
+*        ==== DLAHQR/DLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
+     $          ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== DLAQR0 for big matrices; DLAHQR for small ones ====
+*
+         IF( N.GT.NMIN ) THEN
+            CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                   IHI, Z, LDZ, WORK, LWORK, INFO )
+         ELSE
+*
+*           ==== Small matrix ====
+*
+            CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+     $                   IHI, Z, LDZ, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+*
+*              ==== A rare DLAHQR failure!  DLAQR0 sometimes succeeds
+*              .    when DLAHQR fails. ====
+*
+               KBOT = INFO
+*
+               IF( N.GE.NL ) THEN
+*
+*                 ==== Larger matrices have enough subdiagonal scratch
+*                 .    space to call DLAQR0 directly. ====
+*
+                  CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
+     $                         WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
+*
+               ELSE
+*
+*                 ==== Tiny matrices don't have enough subdiagonal
+*                 .    scratch space to benefit from DLAQR0.  Hence,
+*                 .    tiny matrices must be copied into a larger
+*                 .    array before calling DLAQR0. ====
+*
+                  CALL DLACPY( 'A', N, N, H, LDH, HL, NL )
+                  HL( N+1, N ) = ZERO
+                  CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+     $                         NL )
+                  CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
+     $                         WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+                  IF( WANTT .OR. INFO.NE.0 )
+     $               CALL DLACPY( 'A', N, N, HL, NL, H, LDH )
+               END IF
+            END IF
+         END IF
+*
+*        ==== Clear out the trash, if necessary. ====
+*
+         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+     $      CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+*
+         WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
+      END IF
+*
+*     ==== End of DHSEQR ====
+*
+      END
diff --git a/src/lib/lapack/disnan.f b/src/lib/lapack/disnan.f
new file mode 100644
index 00000000..52003561
--- /dev/null
+++ b/src/lib/lapack/disnan.f
@@ -0,0 +1,33 @@
+      LOGICAL FUNCTION DISNAN(DIN)
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION DIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
+*  otherwise.  To be replaced by the Fortran 2003 intrinsic in the
+*  future.
+*
+*  Arguments
+*  =========
+*
+*  DIN      (input) DOUBLE PRECISION
+*          Input to test for NaN.
+*
+*  =====================================================================
+*
+*  .. External Functions ..
+      LOGICAL DLAISNAN
+      EXTERNAL DLAISNAN
+*  ..
+*  .. Executable Statements ..
+      DISNAN = DLAISNAN(DIN,DIN)
+      RETURN
+      END
diff --git a/src/lib/lapack/dlabad.f b/src/lib/lapack/dlabad.f
new file mode 100644
index 00000000..05ff5d44
--- /dev/null
+++ b/src/lib/lapack/dlabad.f
@@ -0,0 +1,55 @@
+      SUBROUTINE DLABAD( SMALL, LARGE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   LARGE, SMALL
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLABAD takes as input the values computed by DLAMCH for underflow and
+*  overflow, and returns the square root of each of these values if the
+*  log of LARGE is sufficiently large.  This subroutine is intended to
+*  identify machines with a large exponent range, such as the Crays, and
+*  redefine the underflow and overflow limits to be the square roots of
+*  the values computed by DLAMCH.  This subroutine is needed because
+*  DLAMCH does not compensate for poor arithmetic in the upper half of
+*  the exponent range, as is found on a Cray.
+*
+*  Arguments
+*  =========
+*
+*  SMALL   (input/output) DOUBLE PRECISION
+*          On entry, the underflow threshold as computed by DLAMCH.
+*          On exit, if LOG10(LARGE) is sufficiently large, the square
+*          root of SMALL, otherwise unchanged.
+*
+*  LARGE   (input/output) DOUBLE PRECISION
+*          On entry, the overflow threshold as computed by DLAMCH.
+*          On exit, if LOG10(LARGE) is sufficiently large, the square
+*          root of LARGE, otherwise unchanged.
+*
+*  =====================================================================
+*
+*     .. Intrinsic Functions ..
+      INTRINSIC          LOG10, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     If it looks like we're on a Cray, take the square root of
+*     SMALL and LARGE to avoid overflow and underflow problems.
+*
+      IF( LOG10( LARGE ).GT.2000.D0 ) THEN
+         SMALL = SQRT( SMALL )
+         LARGE = SQRT( LARGE )
+      END IF
+*
+      RETURN
+*
+*     End of DLABAD
+*
+      END
diff --git a/src/lib/lapack/dlabrd.f b/src/lib/lapack/dlabrd.f
new file mode 100644
index 00000000..196b130c
--- /dev/null
+++ b/src/lib/lapack/dlabrd.f
@@ -0,0 +1,290 @@
+      SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+     $                   LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDX, LDY, M, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
+     $                   TAUQ( * ), X( LDX, * ), Y( LDY, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLABRD reduces the first NB rows and columns of a real general
+*  m by n matrix A to upper or lower bidiagonal form by an orthogonal
+*  transformation Q' * A * P, and returns the matrices X and Y which
+*  are needed to apply the transformation to the unreduced part of A.
+*
+*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
+*  bidiagonal form.
+*
+*  This is an auxiliary routine called by DGEBRD
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.
+*
+*  NB      (input) INTEGER
+*          The number of leading rows and columns of A to be reduced.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the m by n general matrix to be reduced.
+*          On exit, the first NB rows and columns of the matrix are
+*          overwritten; the rest of the array is unchanged.
+*          If m >= n, elements on and below the diagonal in the first NB
+*            columns, with the array TAUQ, represent the orthogonal
+*            matrix Q as a product of elementary reflectors; and
+*            elements above the diagonal in the first NB rows, with the
+*            array TAUP, represent the orthogonal matrix P as a product
+*            of elementary reflectors.
+*          If m < n, elements below the diagonal in the first NB
+*            columns, with the array TAUQ, represent the orthogonal
+*            matrix Q as a product of elementary reflectors, and
+*            elements on and above the diagonal in the first NB rows,
+*            with the array TAUP, represent the orthogonal matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (NB)
+*          The diagonal elements of the first NB rows and columns of
+*          the reduced matrix.  D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (NB)
+*          The off-diagonal elements of the first NB rows and columns of
+*          the reduced matrix.
+*
+*  TAUQ    (output) DOUBLE PRECISION array dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix Q. See Further Details.
+*
+*  TAUP    (output) DOUBLE PRECISION array, dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the orthogonal matrix P. See Further Details.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (LDX,NB)
+*          The m-by-nb matrix X required to update the unreduced part
+*          of A.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X. LDX >= M.
+*
+*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
+*          The n-by-nb matrix Y required to update the unreduced part
+*          of A.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= N.
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are real scalars, and v and u are real vectors.
+*
+*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
+*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
+*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
+*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
+*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The elements of the vectors v and u together form the m-by-nb matrix
+*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
+*  the transformation to the unreduced part of the matrix, using a block
+*  update of the form:  A := A - V*Y' - X*U'.
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with nb = 2:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
+*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
+*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
+*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
+*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
+*    (  v1  v2  a   a   a  )
+*
+*  where a denotes an element of the original matrix which is unchanged,
+*  vi denotes an element of the vector defining H(i), and ui an element
+*  of the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DLARFG, DSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( M.GE.N ) THEN
+*
+*        Reduce to upper bidiagonal form
+*
+         DO 10 I = 1, NB
+*
+*           Update A(i:m,i)
+*
+            CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+            CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
+     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
+*
+*           Generate reflection Q(i) to annihilate A(i+1:m,i)
+*
+            CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                   TAUQ( I ) )
+            D( I ) = A( I, I )
+            IF( I.LT.N ) THEN
+               A( I, I ) = ONE
+*
+*              Compute Y(i+1:n,i)
+*
+               CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
+     $                     LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
+     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
+     $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+*              Update A(i,i+1:n)
+*
+               CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+               CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
+*
+*              Generate reflection P(i) to annihilate A(i,i+2:n)
+*
+               CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+     $                      LDA, TAUP( I ) )
+               E( I ) = A( I, I+1 )
+               A( I, I+1 ) = ONE
+*
+*              Compute X(i+1:m,i)
+*
+               CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
+     $                     A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Reduce to lower bidiagonal form
+*
+         DO 20 I = 1, NB
+*
+*           Update A(i,i:n)
+*
+            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+            CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
+     $                  X( I, 1 ), LDX, ONE, A( I, I ), LDA )
+*
+*           Generate reflection P(i) to annihilate A(i,i+1:n)
+*
+            CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+     $                   TAUP( I ) )
+            D( I ) = A( I, I )
+            IF( I.LT.M ) THEN
+               A( I, I ) = ONE
+*
+*              Compute X(i+1:m,i)
+*
+               CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
+     $                     A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+*
+*              Update A(i+1:m,i)
+*
+               CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+               CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
+     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
+*
+*              Generate reflection Q(i) to annihilate A(i+2:m,i)
+*
+               CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+     $                      TAUQ( I ) )
+               E( I ) = A( I+1, I )
+               A( I+1, I ) = ONE
+*
+*              Compute Y(i+1:n,i)
+*
+               CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+     $                     LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
+     $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+               CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
+     $                     Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLABRD
+*
+      END
diff --git a/src/lib/lapack/dlacn2.f b/src/lib/lapack/dlacn2.f
new file mode 100644
index 00000000..6705d256
--- /dev/null
+++ b/src/lib/lapack/dlacn2.f
@@ -0,0 +1,214 @@
+      SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KASE, N
+      DOUBLE PRECISION   EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISGN( * ), ISAVE( 3 )
+      DOUBLE PRECISION   V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLACN2 estimates the 1-norm of a square, real matrix A.
+*  Reverse communication is used for evaluating matrix-vector products.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The order of the matrix.  N >= 1.
+*
+*  V      (workspace) DOUBLE PRECISION array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         and DLACN2 must be re-called with all the other parameters
+*         unchanged.
+*
+*  ISGN   (workspace) INTEGER array, dimension (N)
+*
+*  EST    (input/output) DOUBLE PRECISION
+*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+*         unchanged from the previous call to DLACN2.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to DLACN2, KASE should be 0.
+*         On an intermediate return, KASE will be 1 or 2, indicating
+*         whether X should be overwritten by A * X  or A' * X.
+*         On the final return from DLACN2, KASE will again be 0.
+*
+*  ISAVE  (input/output) INTEGER array, dimension (3)
+*         ISAVE is used to save variables between calls to DLACN2
+*
+*  Further Details
+*  ======= =======
+*
+*  Contributed by Nick Higham, University of Manchester.
+*  Originally named SONEST, dated March 16, 1988.
+*
+*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+*  a real or complex matrix, with applications to condition estimation",
+*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+*  This is a thread safe version of DLACON, which uses the array ISAVE
+*  in place of a SAVE statement, as follows:
+*
+*     DLACON     DLACN2
+*      JUMP     ISAVE(1)
+*      J        ISAVE(2)
+*      ITER     ISAVE(3)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, JLAST
+      DOUBLE PRECISION   ALTSGN, ESTOLD, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM
+      EXTERNAL           IDAMAX, DASUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, NINT, SIGN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = ONE / DBLE( N )
+   10    CONTINUE
+         KASE = 1
+         ISAVE( 1 ) = 1
+         RETURN
+      END IF
+*
+      GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 1)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
+*
+   20 CONTINUE
+      IF( N.EQ.1 ) THEN
+         V( 1 ) = X( 1 )
+         EST = ABS( V( 1 ) )
+*        ... QUIT
+         GO TO 150
+      END IF
+      EST = DASUM( N, X, 1 )
+*
+      DO 30 I = 1, N
+         X( I ) = SIGN( ONE, X( I ) )
+         ISGN( I ) = NINT( X( I ) )
+   30 CONTINUE
+      KASE = 2
+      ISAVE( 1 ) = 2
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 2)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+   40 CONTINUE
+      ISAVE( 2 ) = IDAMAX( N, X, 1 )
+      ISAVE( 3 ) = 2
+*
+*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+   50 CONTINUE
+      DO 60 I = 1, N
+         X( I ) = ZERO
+   60 CONTINUE
+      X( ISAVE( 2 ) ) = ONE
+      KASE = 1
+      ISAVE( 1 ) = 3
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 3)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+   70 CONTINUE
+      CALL DCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = DASUM( N, V, 1 )
+      DO 80 I = 1, N
+         IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+     $      GO TO 90
+   80 CONTINUE
+*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+      GO TO 120
+*
+   90 CONTINUE
+*     TEST FOR CYCLING.
+      IF( EST.LE.ESTOLD )
+     $   GO TO 120
+*
+      DO 100 I = 1, N
+         X( I ) = SIGN( ONE, X( I ) )
+         ISGN( I ) = NINT( X( I ) )
+  100 CONTINUE
+      KASE = 2
+      ISAVE( 1 ) = 4
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 4)
+*     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+  110 CONTINUE
+      JLAST = ISAVE( 2 )
+      ISAVE( 2 ) = IDAMAX( N, X, 1 )
+      IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
+     $    ( ISAVE( 3 ).LT.ITMAX ) ) THEN
+         ISAVE( 3 ) = ISAVE( 3 ) + 1
+         GO TO 50
+      END IF
+*
+*     ITERATION COMPLETE.  FINAL STAGE.
+*
+  120 CONTINUE
+      ALTSGN = ONE
+      DO 130 I = 1, N
+         X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
+         ALTSGN = -ALTSGN
+  130 CONTINUE
+      KASE = 1
+      ISAVE( 1 ) = 5
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 5)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+  140 CONTINUE
+      TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL DCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  150 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of DLACN2
+*
+      END
diff --git a/src/lib/lapack/dlacon.f b/src/lib/lapack/dlacon.f
new file mode 100644
index 00000000..f113b03a
--- /dev/null
+++ b/src/lib/lapack/dlacon.f
@@ -0,0 +1,205 @@
+      SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KASE, N
+      DOUBLE PRECISION   EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISGN( * )
+      DOUBLE PRECISION   V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLACON estimates the 1-norm of a square, real matrix A.
+*  Reverse communication is used for evaluating matrix-vector products.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The order of the matrix.  N >= 1.
+*
+*  V      (workspace) DOUBLE PRECISION array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) DOUBLE PRECISION array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         and DLACON must be re-called with all the other parameters
+*         unchanged.
+*
+*  ISGN   (workspace) INTEGER array, dimension (N)
+*
+*  EST    (input/output) DOUBLE PRECISION
+*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+*         unchanged from the previous call to DLACON.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to DLACON, KASE should be 0.
+*         On an intermediate return, KASE will be 1 or 2, indicating
+*         whether X should be overwritten by A * X  or A' * X.
+*         On the final return from DLACON, KASE will again be 0.
+*
+*  Further Details
+*  ======= =======
+*
+*  Contributed by Nick Higham, University of Manchester.
+*  Originally named SONEST, dated March 16, 1988.
+*
+*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+*  a real or complex matrix, with applications to condition estimation",
+*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITER, J, JLAST, JUMP
+      DOUBLE PRECISION   ALTSGN, ESTOLD, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM
+      EXTERNAL           IDAMAX, DASUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, NINT, SIGN
+*     ..
+*     .. Save statement ..
+      SAVE
+*     ..
+*     .. Executable Statements ..
+*
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = ONE / DBLE( N )
+   10    CONTINUE
+         KASE = 1
+         JUMP = 1
+         RETURN
+      END IF
+*
+      GO TO ( 20, 40, 70, 110, 140 )JUMP
+*
+*     ................ ENTRY   (JUMP = 1)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
+*
+   20 CONTINUE
+      IF( N.EQ.1 ) THEN
+         V( 1 ) = X( 1 )
+         EST = ABS( V( 1 ) )
+*        ... QUIT
+         GO TO 150
+      END IF
+      EST = DASUM( N, X, 1 )
+*
+      DO 30 I = 1, N
+         X( I ) = SIGN( ONE, X( I ) )
+         ISGN( I ) = NINT( X( I ) )
+   30 CONTINUE
+      KASE = 2
+      JUMP = 2
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 2)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+   40 CONTINUE
+      J = IDAMAX( N, X, 1 )
+      ITER = 2
+*
+*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+   50 CONTINUE
+      DO 60 I = 1, N
+         X( I ) = ZERO
+   60 CONTINUE
+      X( J ) = ONE
+      KASE = 1
+      JUMP = 3
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 3)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+   70 CONTINUE
+      CALL DCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = DASUM( N, V, 1 )
+      DO 80 I = 1, N
+         IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+     $      GO TO 90
+   80 CONTINUE
+*     REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+      GO TO 120
+*
+   90 CONTINUE
+*     TEST FOR CYCLING.
+      IF( EST.LE.ESTOLD )
+     $   GO TO 120
+*
+      DO 100 I = 1, N
+         X( I ) = SIGN( ONE, X( I ) )
+         ISGN( I ) = NINT( X( I ) )
+  100 CONTINUE
+      KASE = 2
+      JUMP = 4
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 4)
+*     X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+  110 CONTINUE
+      JLAST = J
+      J = IDAMAX( N, X, 1 )
+      IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
+         ITER = ITER + 1
+         GO TO 50
+      END IF
+*
+*     ITERATION COMPLETE.  FINAL STAGE.
+*
+  120 CONTINUE
+      ALTSGN = ONE
+      DO 130 I = 1, N
+         X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
+         ALTSGN = -ALTSGN
+  130 CONTINUE
+      KASE = 1
+      JUMP = 5
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 5)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+  140 CONTINUE
+      TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL DCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  150 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of DLACON
+*
+      END
diff --git a/src/lib/lapack/dlacpy.f b/src/lib/lapack/dlacpy.f
new file mode 100644
index 00000000..d72603a5
--- /dev/null
+++ b/src/lib/lapack/dlacpy.f
@@ -0,0 +1,87 @@
+      SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, LDB, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLACPY copies all or part of a two-dimensional matrix A to another
+*  matrix B.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the part of the matrix A to be copied to B.
+*          = 'U':      Upper triangular part
+*          = 'L':      Lower triangular part
+*          Otherwise:  All of the matrix A
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The m by n matrix A.  If UPLO = 'U', only the upper triangle
+*          or trapezoid is accessed; if UPLO = 'L', only the lower
+*          triangle or trapezoid is accessed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On exit, B = A in the locations specified by UPLO.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+         DO 20 J = 1, N
+            DO 10 I = 1, MIN( J, M )
+               B( I, J ) = A( I, J )
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+         DO 40 J = 1, N
+            DO 30 I = J, M
+               B( I, J ) = A( I, J )
+   30       CONTINUE
+   40    CONTINUE
+      ELSE
+         DO 60 J = 1, N
+            DO 50 I = 1, M
+               B( I, J ) = A( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLACPY
+*
+      END
diff --git a/src/lib/lapack/dladiv.f b/src/lib/lapack/dladiv.f
new file mode 100644
index 00000000..b6a74d1b
--- /dev/null
+++ b/src/lib/lapack/dladiv.f
@@ -0,0 +1,62 @@
+      SUBROUTINE DLADIV( A, B, C, D, P, Q )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, C, D, P, Q
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLADIV performs complex division in  real arithmetic
+*
+*                        a + i*b
+*             p + i*q = ---------
+*                        c + i*d
+*
+*  The algorithm is due to Robert L. Smith and can be found
+*  in D. Knuth, The art of Computer Programming, Vol.2, p.195
+*
+*  Arguments
+*  =========
+*
+*  A       (input) DOUBLE PRECISION
+*  B       (input) DOUBLE PRECISION
+*  C       (input) DOUBLE PRECISION
+*  D       (input) DOUBLE PRECISION
+*          The scalars a, b, c, and d in the above expression.
+*
+*  P       (output) DOUBLE PRECISION
+*  Q       (output) DOUBLE PRECISION
+*          The scalars p and q in the above expression.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      DOUBLE PRECISION   E, F
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ABS( D ).LT.ABS( C ) ) THEN
+         E = D / C
+         F = C + D*E
+         P = ( A+B*E ) / F
+         Q = ( B-A*E ) / F
+      ELSE
+         E = C / D
+         F = D + C*E
+         P = ( B+A*E ) / F
+         Q = ( -A+B*E ) / F
+      END IF
+*
+      RETURN
+*
+*     End of DLADIV
+*
+      END
diff --git a/src/lib/lapack/dlae2.f b/src/lib/lapack/dlae2.f
new file mode 100644
index 00000000..8e81c608
--- /dev/null
+++ b/src/lib/lapack/dlae2.f
@@ -0,0 +1,123 @@
+      SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, C, RT1, RT2
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix
+*     [  A   B  ]
+*     [  B   C  ].
+*  On return, RT1 is the eigenvalue of larger absolute value, and RT2
+*  is the eigenvalue of smaller absolute value.
+*
+*  Arguments
+*  =========
+*
+*  A       (input) DOUBLE PRECISION
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  B       (input) DOUBLE PRECISION
+*          The (1,2) and (2,1) elements of the 2-by-2 matrix.
+*
+*  C       (input) DOUBLE PRECISION
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  RT1     (output) DOUBLE PRECISION
+*          The eigenvalue of larger absolute value.
+*
+*  RT2     (output) DOUBLE PRECISION
+*          The eigenvalue of smaller absolute value.
+*
+*  Further Details
+*  ===============
+*
+*  RT1 is accurate to a few ulps barring over/underflow.
+*
+*  RT2 may be inaccurate if there is massive cancellation in the
+*  determinant A*C-B*B; higher precision or correctly rounded or
+*  correctly truncated arithmetic would be needed to compute RT2
+*  accurately in all cases.
+*
+*  Overflow is possible only if RT1 is within a factor of 5 of overflow.
+*  Underflow is harmless if the input data is 0 or exceeds
+*     underflow_threshold / macheps.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = 0.5D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AB, ACMN, ACMX, ADF, DF, RT, SM, TB
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Compute the eigenvalues
+*
+      SM = A + C
+      DF = A - C
+      ADF = ABS( DF )
+      TB = B + B
+      AB = ABS( TB )
+      IF( ABS( A ).GT.ABS( C ) ) THEN
+         ACMX = A
+         ACMN = C
+      ELSE
+         ACMX = C
+         ACMN = A
+      END IF
+      IF( ADF.GT.AB ) THEN
+         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+      ELSE IF( ADF.LT.AB ) THEN
+         RT = AB*SQRT( ONE+( ADF / AB )**2 )
+      ELSE
+*
+*        Includes case AB=ADF=0
+*
+         RT = AB*SQRT( TWO )
+      END IF
+      IF( SM.LT.ZERO ) THEN
+         RT1 = HALF*( SM-RT )
+*
+*        Order of execution important.
+*        To get fully accurate smaller eigenvalue,
+*        next line needs to be executed in higher precision.
+*
+         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+      ELSE IF( SM.GT.ZERO ) THEN
+         RT1 = HALF*( SM+RT )
+*
+*        Order of execution important.
+*        To get fully accurate smaller eigenvalue,
+*        next line needs to be executed in higher precision.
+*
+         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+      ELSE
+*
+*        Includes case RT1 = RT2 = 0
+*
+         RT1 = HALF*RT
+         RT2 = -HALF*RT
+      END IF
+      RETURN
+*
+*     End of DLAE2
+*
+      END
diff --git a/src/lib/lapack/dlaev2.f b/src/lib/lapack/dlaev2.f
new file mode 100644
index 00000000..49402faa
--- /dev/null
+++ b/src/lib/lapack/dlaev2.f
@@ -0,0 +1,169 @@
+      SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, C, CS1, RT1, RT2, SN1
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
+*     [  A   B  ]
+*     [  B   C  ].
+*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
+*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
+*  eigenvector for RT1, giving the decomposition
+*
+*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]
+*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].
+*
+*  Arguments
+*  =========
+*
+*  A       (input) DOUBLE PRECISION
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  B       (input) DOUBLE PRECISION
+*          The (1,2) element and the conjugate of the (2,1) element of
+*          the 2-by-2 matrix.
+*
+*  C       (input) DOUBLE PRECISION
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  RT1     (output) DOUBLE PRECISION
+*          The eigenvalue of larger absolute value.
+*
+*  RT2     (output) DOUBLE PRECISION
+*          The eigenvalue of smaller absolute value.
+*
+*  CS1     (output) DOUBLE PRECISION
+*  SN1     (output) DOUBLE PRECISION
+*          The vector (CS1, SN1) is a unit right eigenvector for RT1.
+*
+*  Further Details
+*  ===============
+*
+*  RT1 is accurate to a few ulps barring over/underflow.
+*
+*  RT2 may be inaccurate if there is massive cancellation in the
+*  determinant A*C-B*B; higher precision or correctly rounded or
+*  correctly truncated arithmetic would be needed to compute RT2
+*  accurately in all cases.
+*
+*  CS1 and SN1 are accurate to a few ulps barring over/underflow.
+*
+*  Overflow is possible only if RT1 is within a factor of 5 of overflow.
+*  Underflow is harmless if the input data is 0 or exceeds
+*     underflow_threshold / macheps.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = 0.5D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            SGN1, SGN2
+      DOUBLE PRECISION   AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
+     $                   TB, TN
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Compute the eigenvalues
+*
+      SM = A + C
+      DF = A - C
+      ADF = ABS( DF )
+      TB = B + B
+      AB = ABS( TB )
+      IF( ABS( A ).GT.ABS( C ) ) THEN
+         ACMX = A
+         ACMN = C
+      ELSE
+         ACMX = C
+         ACMN = A
+      END IF
+      IF( ADF.GT.AB ) THEN
+         RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+      ELSE IF( ADF.LT.AB ) THEN
+         RT = AB*SQRT( ONE+( ADF / AB )**2 )
+      ELSE
+*
+*        Includes case AB=ADF=0
+*
+         RT = AB*SQRT( TWO )
+      END IF
+      IF( SM.LT.ZERO ) THEN
+         RT1 = HALF*( SM-RT )
+         SGN1 = -1
+*
+*        Order of execution important.
+*        To get fully accurate smaller eigenvalue,
+*        next line needs to be executed in higher precision.
+*
+         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+      ELSE IF( SM.GT.ZERO ) THEN
+         RT1 = HALF*( SM+RT )
+         SGN1 = 1
+*
+*        Order of execution important.
+*        To get fully accurate smaller eigenvalue,
+*        next line needs to be executed in higher precision.
+*
+         RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+      ELSE
+*
+*        Includes case RT1 = RT2 = 0
+*
+         RT1 = HALF*RT
+         RT2 = -HALF*RT
+         SGN1 = 1
+      END IF
+*
+*     Compute the eigenvector
+*
+      IF( DF.GE.ZERO ) THEN
+         CS = DF + RT
+         SGN2 = 1
+      ELSE
+         CS = DF - RT
+         SGN2 = -1
+      END IF
+      ACS = ABS( CS )
+      IF( ACS.GT.AB ) THEN
+         CT = -TB / CS
+         SN1 = ONE / SQRT( ONE+CT*CT )
+         CS1 = CT*SN1
+      ELSE
+         IF( AB.EQ.ZERO ) THEN
+            CS1 = ONE
+            SN1 = ZERO
+         ELSE
+            TN = -CS / TB
+            CS1 = ONE / SQRT( ONE+TN*TN )
+            SN1 = TN*CS1
+         END IF
+      END IF
+      IF( SGN1.EQ.SGN2 ) THEN
+         TN = CS1
+         CS1 = -SN1
+         SN1 = TN
+      END IF
+      RETURN
+*
+*     End of DLAEV2
+*
+      END
diff --git a/src/lib/lapack/dlaexc.f b/src/lib/lapack/dlaexc.f
new file mode 100644
index 00000000..18e7d247
--- /dev/null
+++ b/src/lib/lapack/dlaexc.f
@@ -0,0 +1,354 @@
+      SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ
+      INTEGER            INFO, J1, LDQ, LDT, N, N1, N2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
+*  an upper quasi-triangular matrix T by an orthogonal similarity
+*  transformation.
+*
+*  T must be in Schur canonical form, that is, block upper triangular
+*  with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
+*  has its diagonal elemnts equal and its off-diagonal elements of
+*  opposite sign.
+*
+*  Arguments
+*  =========
+*
+*  WANTQ   (input) LOGICAL
+*          = .TRUE. : accumulate the transformation in the matrix Q;
+*          = .FALSE.: do not accumulate the transformation.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+*          On entry, the upper quasi-triangular matrix T, in Schur
+*          canonical form.
+*          On exit, the updated matrix T, again in Schur canonical form.
+*
+*  LDT     (input)  INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
+*          On exit, if WANTQ is .TRUE., the updated matrix Q.
+*          If WANTQ is .FALSE., Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
+*
+*  J1      (input) INTEGER
+*          The index of the first row of the first block T11.
+*
+*  N1      (input) INTEGER
+*          The order of the first block T11. N1 = 0, 1 or 2.
+*
+*  N2      (input) INTEGER
+*          The order of the second block T22. N2 = 0, 1 or 2.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          = 1: the transformed matrix T would be too far from Schur
+*               form; the blocks are not swapped and T and Q are
+*               unchanged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 1.0D+1 )
+      INTEGER            LDD, LDX
+      PARAMETER          ( LDD = 4, LDX = 2 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IERR, J2, J3, J4, K, ND
+      DOUBLE PRECISION   CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
+     $                   T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
+     $                   WR1, WR2, XNORM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
+     $                   X( LDX, 2 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLANGE
+      EXTERNAL           DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2,
+     $                   DROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
+     $   RETURN
+      IF( J1+N1.GT.N )
+     $   RETURN
+*
+      J2 = J1 + 1
+      J3 = J1 + 2
+      J4 = J1 + 3
+*
+      IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
+*
+*        Swap two 1-by-1 blocks.
+*
+         T11 = T( J1, J1 )
+         T22 = T( J2, J2 )
+*
+*        Determine the transformation to perform the interchange.
+*
+         CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
+*
+*        Apply transformation to the matrix T.
+*
+         IF( J3.LE.N )
+     $      CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
+     $                 SN )
+         CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+*
+         T( J1, J1 ) = T22
+         T( J2, J2 ) = T11
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+         END IF
+*
+      ELSE
+*
+*        Swapping involves at least one 2-by-2 block.
+*
+*        Copy the diagonal block of order N1+N2 to the local array D
+*        and compute its norm.
+*
+         ND = N1 + N2
+         CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
+         DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK )
+*
+*        Compute machine-dependent threshold for test for accepting
+*        swap.
+*
+         EPS = DLAMCH( 'P' )
+         SMLNUM = DLAMCH( 'S' ) / EPS
+         THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+*        Solve T11*X - X*T22 = scale*T12 for X.
+*
+         CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
+     $                D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
+     $                LDX, XNORM, IERR )
+*
+*        Swap the adjacent diagonal blocks.
+*
+         K = N1 + N1 + N2 - 3
+         GO TO ( 10, 20, 30 )K
+*
+   10    CONTINUE
+*
+*        N1 = 1, N2 = 2: generate elementary reflector H so that:
+*
+*        ( scale, X11, X12 ) H = ( 0, 0, * )
+*
+         U( 1 ) = SCALE
+         U( 2 ) = X( 1, 1 )
+         U( 3 ) = X( 1, 2 )
+         CALL DLARFG( 3, U( 3 ), U, 1, TAU )
+         U( 3 ) = ONE
+         T11 = T( J1, J1 )
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+         CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+*        Test whether to reject swap.
+*
+         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
+     $       3 )-T11 ) ).GT.THRESH )GO TO 50
+*
+*        Accept swap: apply transformation to the entire matrix T.
+*
+         CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
+         CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+*
+         T( J3, J1 ) = ZERO
+         T( J3, J2 ) = ZERO
+         T( J3, J3 ) = T11
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+         END IF
+         GO TO 40
+*
+   20    CONTINUE
+*
+*        N1 = 2, N2 = 1: generate elementary reflector H so that:
+*
+*        H (  -X11 ) = ( * )
+*          (  -X21 ) = ( 0 )
+*          ( scale ) = ( 0 )
+*
+         U( 1 ) = -X( 1, 1 )
+         U( 2 ) = -X( 2, 1 )
+         U( 3 ) = SCALE
+         CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
+         U( 1 ) = ONE
+         T33 = T( J3, J3 )
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+         CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+*        Test whether to reject swap.
+*
+         IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
+     $       1 )-T33 ) ).GT.THRESH )GO TO 50
+*
+*        Accept swap: apply transformation to the entire matrix T.
+*
+         CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+         CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
+*
+         T( J1, J1 ) = T33
+         T( J2, J1 ) = ZERO
+         T( J3, J1 ) = ZERO
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+         END IF
+         GO TO 40
+*
+   30    CONTINUE
+*
+*        N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
+*        that:
+*
+*        H(2) H(1) (  -X11  -X12 ) = (  *  * )
+*                  (  -X21  -X22 )   (  0  * )
+*                  ( scale    0  )   (  0  0 )
+*                  (    0  scale )   (  0  0 )
+*
+         U1( 1 ) = -X( 1, 1 )
+         U1( 2 ) = -X( 2, 1 )
+         U1( 3 ) = SCALE
+         CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
+         U1( 1 ) = ONE
+*
+         TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
+         U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
+         U2( 2 ) = -TEMP*U1( 3 )
+         U2( 3 ) = SCALE
+         CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
+         U2( 1 ) = ONE
+*
+*        Perform swap provisionally on diagonal block in D.
+*
+         CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
+         CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
+         CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
+         CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
+*
+*        Test whether to reject swap.
+*
+         IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
+     $       ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
+*
+*        Accept swap: apply transformation to the entire matrix T.
+*
+         CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
+         CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
+         CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
+         CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
+*
+         T( J3, J1 ) = ZERO
+         T( J3, J2 ) = ZERO
+         T( J4, J1 ) = ZERO
+         T( J4, J2 ) = ZERO
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
+            CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
+         END IF
+*
+   40    CONTINUE
+*
+         IF( N2.EQ.2 ) THEN
+*
+*           Standardize new 2-by-2 block T11
+*
+            CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
+     $                   T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
+            CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
+     $                 CS, SN )
+            CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+            IF( WANTQ )
+     $         CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+         END IF
+*
+         IF( N1.EQ.2 ) THEN
+*
+*           Standardize new 2-by-2 block T22
+*
+            J3 = J1 + N2
+            J4 = J3 + 1
+            CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
+     $                   T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
+            IF( J3+2.LE.N )
+     $         CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
+     $                    LDT, CS, SN )
+            CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
+            IF( WANTQ )
+     $         CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
+         END IF
+*
+      END IF
+      RETURN
+*
+*     Exit with INFO = 1 if swap was rejected.
+*
+   50 CONTINUE
+      INFO = 1
+      RETURN
+*
+*     End of DLAEXC
+*
+      END
diff --git a/src/lib/lapack/dlag2.f b/src/lib/lapack/dlag2.f
new file mode 100644
index 00000000..e754203b
--- /dev/null
+++ b/src/lib/lapack/dlag2.f
@@ -0,0 +1,300 @@
+      SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
+     $                  WR2, WI )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB
+      DOUBLE PRECISION   SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
+*  problem  A - w B, with scaling as necessary to avoid over-/underflow.
+*
+*  The scaling factor "s" results in a modified eigenvalue equation
+*
+*      s A - w B
+*
+*  where  s  is a non-negative scaling factor chosen so that  w,  w B,
+*  and  s A  do not overflow and, if possible, do not underflow, either.
+*
+*  Arguments
+*  =========
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA, 2)
+*          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm
+*          is less than 1/SAFMIN.  Entries less than
+*          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= 2.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB, 2)
+*          On entry, the 2 x 2 upper triangular matrix B.  It is
+*          assumed that the one-norm of B is less than 1/SAFMIN.  The
+*          diagonals should be at least sqrt(SAFMIN) times the largest
+*          element of B (in absolute value); if a diagonal is smaller
+*          than that, then  +/- sqrt(SAFMIN) will be used instead of
+*          that diagonal.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= 2.
+*
+*  SAFMIN  (input) DOUBLE PRECISION
+*          The smallest positive number s.t. 1/SAFMIN does not
+*          overflow.  (This should always be DLAMCH('S') -- it is an
+*          argument in order to avoid having to call DLAMCH frequently.)
+*
+*  SCALE1  (output) DOUBLE PRECISION
+*          A scaling factor used to avoid over-/underflow in the
+*          eigenvalue equation which defines the first eigenvalue.  If
+*          the eigenvalues are complex, then the eigenvalues are
+*          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the
+*          exponent range of the machine), SCALE1=SCALE2, and SCALE1
+*          will always be positive.  If the eigenvalues are real, then
+*          the first (real) eigenvalue is  WR1 / SCALE1 , but this may
+*          overflow or underflow, and in fact, SCALE1 may be zero or
+*          less than the underflow threshhold if the exact eigenvalue
+*          is sufficiently large.
+*
+*  SCALE2  (output) DOUBLE PRECISION
+*          A scaling factor used to avoid over-/underflow in the
+*          eigenvalue equation which defines the second eigenvalue.  If
+*          the eigenvalues are complex, then SCALE2=SCALE1.  If the
+*          eigenvalues are real, then the second (real) eigenvalue is
+*          WR2 / SCALE2 , but this may overflow or underflow, and in
+*          fact, SCALE2 may be zero or less than the underflow
+*          threshhold if the exact eigenvalue is sufficiently large.
+*
+*  WR1     (output) DOUBLE PRECISION
+*          If the eigenvalue is real, then WR1 is SCALE1 times the
+*          eigenvalue closest to the (2,2) element of A B**(-1).  If the
+*          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
+*          part of the eigenvalues.
+*
+*  WR2     (output) DOUBLE PRECISION
+*          If the eigenvalue is real, then WR2 is SCALE2 times the
+*          other eigenvalue.  If the eigenvalue is complex, then
+*          WR1=WR2 is SCALE1 times the real part of the eigenvalues.
+*
+*  WI      (output) DOUBLE PRECISION
+*          If the eigenvalue is real, then WI is zero.  If the
+*          eigenvalue is complex, then WI is SCALE1 times the imaginary
+*          part of the eigenvalues.  WI will always be non-negative.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = ONE / TWO )
+      DOUBLE PRECISION   FUZZY1
+      PARAMETER          ( FUZZY1 = ONE+1.0D-5 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
+     $                   AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
+     $                   BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
+     $                   DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
+     $                   SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
+     $                   WSCALE, WSIZE, WSMALL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      RTMIN = SQRT( SAFMIN )
+      RTMAX = ONE / RTMIN
+      SAFMAX = ONE / SAFMIN
+*
+*     Scale A
+*
+      ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+     $        ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+      ASCALE = ONE / ANORM
+      A11 = ASCALE*A( 1, 1 )
+      A21 = ASCALE*A( 2, 1 )
+      A12 = ASCALE*A( 1, 2 )
+      A22 = ASCALE*A( 2, 2 )
+*
+*     Perturb B if necessary to insure non-singularity
+*
+      B11 = B( 1, 1 )
+      B12 = B( 1, 2 )
+      B22 = B( 2, 2 )
+      BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
+      IF( ABS( B11 ).LT.BMIN )
+     $   B11 = SIGN( BMIN, B11 )
+      IF( ABS( B22 ).LT.BMIN )
+     $   B22 = SIGN( BMIN, B22 )
+*
+*     Scale B
+*
+      BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
+      BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
+      BSCALE = ONE / BSIZE
+      B11 = B11*BSCALE
+      B12 = B12*BSCALE
+      B22 = B22*BSCALE
+*
+*     Compute larger eigenvalue by method described by C. van Loan
+*
+*     ( AS is A shifted by -SHIFT*B )
+*
+      BINV11 = ONE / B11
+      BINV22 = ONE / B22
+      S1 = A11*BINV11
+      S2 = A22*BINV22
+      IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
+         AS12 = A12 - S1*B12
+         AS22 = A22 - S1*B22
+         SS = A21*( BINV11*BINV22 )
+         ABI22 = AS22*BINV22 - SS*B12
+         PP = HALF*ABI22
+         SHIFT = S1
+      ELSE
+         AS12 = A12 - S2*B12
+         AS11 = A11 - S2*B11
+         SS = A21*( BINV11*BINV22 )
+         ABI22 = -SS*B12
+         PP = HALF*( AS11*BINV11+ABI22 )
+         SHIFT = S2
+      END IF
+      QQ = SS*AS12
+      IF( ABS( PP*RTMIN ).GE.ONE ) THEN
+         DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
+         R = SQRT( ABS( DISCR ) )*RTMAX
+      ELSE
+         IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
+            DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
+            R = SQRT( ABS( DISCR ) )*RTMIN
+         ELSE
+            DISCR = PP**2 + QQ
+            R = SQRT( ABS( DISCR ) )
+         END IF
+      END IF
+*
+*     Note: the test of R in the following IF is to cover the case when
+*           DISCR is small and negative and is flushed to zero during
+*           the calculation of R.  On machines which have a consistent
+*           flush-to-zero threshhold and handle numbers above that
+*           threshhold correctly, it would not be necessary.
+*
+      IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
+         SUM = PP + SIGN( R, PP )
+         DIFF = PP - SIGN( R, PP )
+         WBIG = SHIFT + SUM
+*
+*        Compute smaller eigenvalue
+*
+         WSMALL = SHIFT + DIFF
+         IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
+            WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
+            WSMALL = WDET / WBIG
+         END IF
+*
+*        Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
+*        for WR1.
+*
+         IF( PP.GT.ABI22 ) THEN
+            WR1 = MIN( WBIG, WSMALL )
+            WR2 = MAX( WBIG, WSMALL )
+         ELSE
+            WR1 = MAX( WBIG, WSMALL )
+            WR2 = MIN( WBIG, WSMALL )
+         END IF
+         WI = ZERO
+      ELSE
+*
+*        Complex eigenvalues
+*
+         WR1 = SHIFT + PP
+         WR2 = WR1
+         WI = R
+      END IF
+*
+*     Further scaling to avoid underflow and overflow in computing
+*     SCALE1 and overflow in computing w*B.
+*
+*     This scale factor (WSCALE) is bounded from above using C1 and C2,
+*     and from below using C3 and C4.
+*        C1 implements the condition  s A  must never overflow.
+*        C2 implements the condition  w B  must never overflow.
+*        C3, with C2,
+*           implement the condition that s A - w B must never overflow.
+*        C4 implements the condition  s    should not underflow.
+*        C5 implements the condition  max(s,|w|) should be at least 2.
+*
+      C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
+      C2 = SAFMIN*MAX( ONE, BNORM )
+      C3 = BSIZE*SAFMIN
+      IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
+         C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
+      ELSE
+         C4 = ONE
+      END IF
+      IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
+         C5 = MIN( ONE, ASCALE*BSIZE )
+      ELSE
+         C5 = ONE
+      END IF
+*
+*     Scale first eigenvalue
+*
+      WABS = ABS( WR1 ) + ABS( WI )
+      WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
+     $        MIN( C4, HALF*MAX( WABS, C5 ) ) )
+      IF( WSIZE.NE.ONE ) THEN
+         WSCALE = ONE / WSIZE
+         IF( WSIZE.GT.ONE ) THEN
+            SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+     $               MIN( ASCALE, BSIZE )
+         ELSE
+            SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+     $               MAX( ASCALE, BSIZE )
+         END IF
+         WR1 = WR1*WSCALE
+         IF( WI.NE.ZERO ) THEN
+            WI = WI*WSCALE
+            WR2 = WR1
+            SCALE2 = SCALE1
+         END IF
+      ELSE
+         SCALE1 = ASCALE*BSIZE
+         SCALE2 = SCALE1
+      END IF
+*
+*     Scale second eigenvalue (if real)
+*
+      IF( WI.EQ.ZERO ) THEN
+         WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
+     $           MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
+         IF( WSIZE.NE.ONE ) THEN
+            WSCALE = ONE / WSIZE
+            IF( WSIZE.GT.ONE ) THEN
+               SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+     $                  MIN( ASCALE, BSIZE )
+            ELSE
+               SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+     $                  MAX( ASCALE, BSIZE )
+            END IF
+            WR2 = WR2*WSCALE
+         ELSE
+            SCALE2 = ASCALE*BSIZE
+         END IF
+      END IF
+*
+*     End of DLAG2
+*
+      RETURN
+      END
diff --git a/src/lib/lapack/dlagv2.f b/src/lib/lapack/dlagv2.f
new file mode 100644
index 00000000..15bcb0b9
--- /dev/null
+++ b/src/lib/lapack/dlagv2.f
@@ -0,0 +1,287 @@
+      SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
+     $                   CSR, SNR )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDB
+      DOUBLE PRECISION   CSL, CSR, SNL, SNR
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
+     $                   B( LDB, * ), BETA( 2 )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
+*  matrix pencil (A,B) where B is upper triangular. This routine
+*  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
+*  SNR such that
+*
+*  1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
+*     types), then
+*
+*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
+*     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
+*
+*     [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
+*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],
+*
+*  2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
+*     then
+*
+*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
+*     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
+*
+*     [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
+*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]
+*
+*     where b11 >= b22 > 0.
+*
+*
+*  Arguments
+*  =========
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
+*          On entry, the 2 x 2 matrix A.
+*          On exit, A is overwritten by the ``A-part'' of the
+*          generalized Schur form.
+*
+*  LDA     (input) INTEGER
+*          THe leading dimension of the array A.  LDA >= 2.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
+*          On entry, the upper triangular 2 x 2 matrix B.
+*          On exit, B is overwritten by the ``B-part'' of the
+*          generalized Schur form.
+*
+*  LDB     (input) INTEGER
+*          THe leading dimension of the array B.  LDB >= 2.
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
+*  BETA    (output) DOUBLE PRECISION array, dimension (2)
+*          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
+*          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may
+*          be zero.
+*
+*  CSL     (output) DOUBLE PRECISION
+*          The cosine of the left rotation matrix.
+*
+*  SNL     (output) DOUBLE PRECISION
+*          The sine of the left rotation matrix.
+*
+*  CSR     (output) DOUBLE PRECISION
+*          The cosine of the right rotation matrix.
+*
+*  SNR     (output) DOUBLE PRECISION
+*          The sine of the right rotation matrix.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
+     $                   R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
+     $                   WR2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAG2, DLARTG, DLASV2, DROT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = DLAMCH( 'S' )
+      ULP = DLAMCH( 'P' )
+*
+*     Scale A
+*
+      ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+     $        ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+      ASCALE = ONE / ANORM
+      A( 1, 1 ) = ASCALE*A( 1, 1 )
+      A( 1, 2 ) = ASCALE*A( 1, 2 )
+      A( 2, 1 ) = ASCALE*A( 2, 1 )
+      A( 2, 2 ) = ASCALE*A( 2, 2 )
+*
+*     Scale B
+*
+      BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
+     $        SAFMIN )
+      BSCALE = ONE / BNORM
+      B( 1, 1 ) = BSCALE*B( 1, 1 )
+      B( 1, 2 ) = BSCALE*B( 1, 2 )
+      B( 2, 2 ) = BSCALE*B( 2, 2 )
+*
+*     Check if A can be deflated
+*
+      IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
+         CSL = ONE
+         SNL = ZERO
+         CSR = ONE
+         SNR = ZERO
+         A( 2, 1 ) = ZERO
+         B( 2, 1 ) = ZERO
+*
+*     Check if B is singular
+*
+      ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
+         CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+         CSR = ONE
+         SNR = ZERO
+         CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+         CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+         A( 2, 1 ) = ZERO
+         B( 1, 1 ) = ZERO
+         B( 2, 1 ) = ZERO
+*
+      ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
+         CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
+         SNR = -SNR
+         CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+         CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+         CSL = ONE
+         SNL = ZERO
+         A( 2, 1 ) = ZERO
+         B( 2, 1 ) = ZERO
+         B( 2, 2 ) = ZERO
+*
+      ELSE
+*
+*        B is nonsingular, first compute the eigenvalues of (A,B)
+*
+         CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
+     $               WI )
+*
+         IF( WI.EQ.ZERO ) THEN
+*
+*           two real eigenvalues, compute s*A-w*B
+*
+            H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
+            H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
+            H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
+*
+            RR = DLAPY2( H1, H2 )
+            QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
+*
+            IF( RR.GT.QQ ) THEN
+*
+*              find right rotation matrix to zero 1,1 element of
+*              (sA - wB)
+*
+               CALL DLARTG( H2, H1, CSR, SNR, T )
+*
+            ELSE
+*
+*              find right rotation matrix to zero 2,1 element of
+*              (sA - wB)
+*
+               CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
+*
+            END IF
+*
+            SNR = -SNR
+            CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+            CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+*           compute inf norms of A and B
+*
+            H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
+     $           ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
+            H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+     $           ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+*
+            IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
+*
+*              find left rotation matrix Q to zero out B(2,1)
+*
+               CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
+*
+            ELSE
+*
+*              find left rotation matrix Q to zero out A(2,1)
+*
+               CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+*
+            END IF
+*
+            CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+            CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+*
+            A( 2, 1 ) = ZERO
+            B( 2, 1 ) = ZERO
+*
+         ELSE
+*
+*           a pair of complex conjugate eigenvalues
+*           first compute the SVD of the matrix B
+*
+            CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
+     $                   CSR, SNL, CSL )
+*
+*           Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
+*           Z is right rotation matrix computed from DLASV2
+*
+            CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+            CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+            CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+            CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+            B( 2, 1 ) = ZERO
+            B( 1, 2 ) = ZERO
+*
+         END IF
+*
+      END IF
+*
+*     Unscaling
+*
+      A( 1, 1 ) = ANORM*A( 1, 1 )
+      A( 2, 1 ) = ANORM*A( 2, 1 )
+      A( 1, 2 ) = ANORM*A( 1, 2 )
+      A( 2, 2 ) = ANORM*A( 2, 2 )
+      B( 1, 1 ) = BNORM*B( 1, 1 )
+      B( 2, 1 ) = BNORM*B( 2, 1 )
+      B( 1, 2 ) = BNORM*B( 1, 2 )
+      B( 2, 2 ) = BNORM*B( 2, 2 )
+*
+      IF( WI.EQ.ZERO ) THEN
+         ALPHAR( 1 ) = A( 1, 1 )
+         ALPHAR( 2 ) = A( 2, 2 )
+         ALPHAI( 1 ) = ZERO
+         ALPHAI( 2 ) = ZERO
+         BETA( 1 ) = B( 1, 1 )
+         BETA( 2 ) = B( 2, 2 )
+      ELSE
+         ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
+         ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
+         ALPHAR( 2 ) = ALPHAR( 1 )
+         ALPHAI( 2 ) = -ALPHAI( 1 )
+         BETA( 1 ) = ONE
+         BETA( 2 ) = ONE
+      END IF
+*
+      RETURN
+*
+*     End of DLAGV2
+*
+      END
diff --git a/src/lib/lapack/dlahqr.f b/src/lib/lapack/dlahqr.f
new file mode 100644
index 00000000..449a3770
--- /dev/null
+++ b/src/lib/lapack/dlahqr.f
@@ -0,0 +1,501 @@
+      SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     DLAHQR is an auxiliary routine called by DHSEQR to update the
+*     eigenvalues and Schur decomposition already computed by DHSEQR, by
+*     dealing with the Hessenberg submatrix in rows and columns ILO to
+*     IHI.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*     ILO     (input) INTEGER
+*     IHI     (input) INTEGER
+*          It is assumed that H is already upper quasi-triangular in
+*          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
+*          ILO = 1). DLAHQR works primarily with the Hessenberg
+*          submatrix in rows and columns ILO to IHI, but applies
+*          transformations to all of H if WANTT is .TRUE..
+*          1 <= ILO <= max(1,IHI); IHI <= N.
+*
+*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*          On entry, the upper Hessenberg matrix H.
+*          On exit, if INFO is zero and if WANTT is .TRUE., H is upper
+*          quasi-triangular in rows and columns ILO:IHI, with any
+*          2-by-2 diagonal blocks in standard form. If INFO is zero
+*          and WANTT is .FALSE., the contents of H are unspecified on
+*          exit.  The output state of H if INFO is nonzero is given
+*          below under the description of INFO.
+*
+*     LDH     (input) INTEGER
+*          The leading dimension of the array H. LDH >= max(1,N).
+*
+*     WR      (output) DOUBLE PRECISION array, dimension (N)
+*     WI      (output) DOUBLE PRECISION array, dimension (N)
+*          The real and imaginary parts, respectively, of the computed
+*          eigenvalues ILO to IHI are stored in the corresponding
+*          elements of WR and WI. If two eigenvalues are computed as a
+*          complex conjugate pair, they are stored in consecutive
+*          elements of WR and WI, say the i-th and (i+1)th, with
+*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+*          eigenvalues are stored in the same order as on the diagonal
+*          of the Schur form returned in H, with WR(i) = H(i,i), and, if
+*          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
+*          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE..
+*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          If WANTZ is .TRUE., on entry Z must contain the current
+*          matrix Z of transformations accumulated by DHSEQR, and on
+*          exit Z has been updated; transformations are applied only to
+*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
+*          If WANTZ is .FALSE., Z is not referenced.
+*
+*     LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= max(1,N).
+*
+*     INFO    (output) INTEGER
+*           =   0: successful exit
+*          .GT. 0: If INFO = i, DLAHQR failed to compute all the
+*                  eigenvalues ILO to IHI in a total of 30 iterations
+*                  per eigenvalue; elements i+1:ihi of WR and WI
+*                  contain those eigenvalues which have been
+*                  successfully computed.
+*
+*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,
+*                  the remaining unconverged eigenvalues are the
+*                  eigenvalues of the upper Hessenberg matrix rows
+*                  and columns ILO thorugh INFO of the final, output
+*                  value of H.
+*
+*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*          (*)       (initial value of H)*U  = U*(final value of H)
+*                  where U is an orthognal matrix.    The final
+*                  value of H is upper Hessenberg and triangular in
+*                  rows and columns INFO+1 through IHI.
+*
+*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*                      (final value of Z)  = (initial value of Z)*U
+*                  where U is the orthogonal matrix in (*)
+*                  (regardless of the value of WANTT.)
+*
+*     Further Details
+*     ===============
+*
+*     02-96 Based on modifications by
+*     David Day, Sandia National Laboratory, USA
+*
+*     12-04 Further modifications by
+*     Ralph Byers, University of Kansas, USA
+*
+*       This is a modified version of DLAHQR from LAPACK version 3.0.
+*       It is (1) more robust against overflow and underflow and
+*       (2) adopts the more conservative Ahues & Tisseur stopping
+*       criterion (LAWN 122, 1997).
+*
+*     =========================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 30 )
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 )
+      DOUBLE PRECISION   DAT1, DAT2
+      PARAMETER          ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
+     $                   H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
+     $                   SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
+     $                   ULP, V2, V3
+      INTEGER            I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   V( 3 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLABAD, DLANV2, DLARFG, DROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( ILO.EQ.IHI ) THEN
+         WR( ILO ) = H( ILO, ILO )
+         WI( ILO ) = ZERO
+         RETURN
+      END IF
+*
+*     ==== clear out the trash ====
+      DO 10 J = ILO, IHI - 3
+         H( J+2, J ) = ZERO
+         H( J+3, J ) = ZERO
+   10 CONTINUE
+      IF( ILO.LE.IHI-2 )
+     $   H( IHI, IHI-2 ) = ZERO
+*
+      NH = IHI - ILO + 1
+      NZ = IHIZ - ILOZ + 1
+*
+*     Set machine-dependent constants for the stopping criterion.
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
+*
+*     I1 and I2 are the indices of the first row and last column of H
+*     to which transformations must be applied. If eigenvalues only are
+*     being computed, I1 and I2 are set inside the main loop.
+*
+      IF( WANTT ) THEN
+         I1 = 1
+         I2 = N
+      END IF
+*
+*     The main loop begins here. I is the loop index and decreases from
+*     IHI to ILO in steps of 1 or 2. Each iteration of the loop works
+*     with the active submatrix in rows and columns L to I.
+*     Eigenvalues I+1 to IHI have already converged. Either L = ILO or
+*     H(L,L-1) is negligible so that the matrix splits.
+*
+      I = IHI
+   20 CONTINUE
+      L = ILO
+      IF( I.LT.ILO )
+     $   GO TO 160
+*
+*     Perform QR iterations on rows and columns ILO to I until a
+*     submatrix of order 1 or 2 splits off at the bottom because a
+*     subdiagonal element has become negligible.
+*
+      DO 140 ITS = 0, ITMAX
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 30 K = I, L + 1, -1
+            IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
+     $         GO TO 40
+            TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
+            IF( TST.EQ.ZERO ) THEN
+               IF( K-2.GE.ILO )
+     $            TST = TST + ABS( H( K-1, K-2 ) )
+               IF( K+1.LE.IHI )
+     $            TST = TST + ABS( H( K+1, K ) )
+            END IF
+*           ==== The following is a conservative small subdiagonal
+*           .    deflation  criterion due to Ahues & Tisseur (LAWN 122,
+*           .    1997). It has better mathematical foundation and
+*           .    improves accuracy in some cases.  ====
+            IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
+               AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+               BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+               AA = MAX( ABS( H( K, K ) ),
+     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
+               BB = MIN( ABS( H( K, K ) ),
+     $              ABS( H( K-1, K-1 )-H( K, K ) ) )
+               S = AA + AB
+               IF( BA*( AB / S ).LE.MAX( SMLNUM,
+     $             ULP*( BB*( AA / S ) ) ) )GO TO 40
+            END IF
+   30    CONTINUE
+   40    CONTINUE
+         L = K
+         IF( L.GT.ILO ) THEN
+*
+*           H(L,L-1) is negligible
+*
+            H( L, L-1 ) = ZERO
+         END IF
+*
+*        Exit from loop if a submatrix of order 1 or 2 has split off.
+*
+         IF( L.GE.I-1 )
+     $      GO TO 150
+*
+*        Now the active submatrix is in rows and columns L to I. If
+*        eigenvalues only are being computed, only the active submatrix
+*        need be transformed.
+*
+         IF( .NOT.WANTT ) THEN
+            I1 = L
+            I2 = I
+         END IF
+*
+         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
+*
+*           Exceptional shift.
+*
+            H11 = DAT1*S + H( I, I )
+            H12 = DAT2*S
+            H21 = S
+            H22 = H11
+         ELSE
+*
+*           Prepare to use Francis' double shift
+*           (i.e. 2nd degree generalized Rayleigh quotient)
+*
+            H11 = H( I-1, I-1 )
+            H21 = H( I, I-1 )
+            H12 = H( I-1, I )
+            H22 = H( I, I )
+         END IF
+         S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
+         IF( S.EQ.ZERO ) THEN
+            RT1R = ZERO
+            RT1I = ZERO
+            RT2R = ZERO
+            RT2I = ZERO
+         ELSE
+            H11 = H11 / S
+            H21 = H21 / S
+            H12 = H12 / S
+            H22 = H22 / S
+            TR = ( H11+H22 ) / TWO
+            DET = ( H11-TR )*( H22-TR ) - H12*H21
+            RTDISC = SQRT( ABS( DET ) )
+            IF( DET.GE.ZERO ) THEN
+*
+*              ==== complex conjugate shifts ====
+*
+               RT1R = TR*S
+               RT2R = RT1R
+               RT1I = RTDISC*S
+               RT2I = -RT1I
+            ELSE
+*
+*              ==== real shifts (use only one of them)  ====
+*
+               RT1R = TR + RTDISC
+               RT2R = TR - RTDISC
+               IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
+                  RT1R = RT1R*S
+                  RT2R = RT1R
+               ELSE
+                  RT2R = RT2R*S
+                  RT1R = RT2R
+               END IF
+               RT1I = ZERO
+               RT2I = ZERO
+            END IF
+         END IF
+*
+*        Look for two consecutive small subdiagonal elements.
+*
+         DO 50 M = I - 2, L, -1
+*           Determine the effect of starting the double-shift QR
+*           iteration at row M, and see if this would make H(M,M-1)
+*           negligible.  (The following uses scaling to avoid
+*           overflows and most underflows.)
+*
+            H21S = H( M+1, M )
+            S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
+            H21S = H( M+1, M ) / S
+            V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
+     $               ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
+            V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
+            V( 3 ) = H21S*H( M+2, M+1 )
+            S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
+            V( 1 ) = V( 1 ) / S
+            V( 2 ) = V( 2 ) / S
+            V( 3 ) = V( 3 ) / S
+            IF( M.EQ.L )
+     $         GO TO 60
+            IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
+     $          ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
+     $          M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
+   50    CONTINUE
+   60    CONTINUE
+*
+*        Double-shift QR step
+*
+         DO 130 K = M, I - 1
+*
+*           The first iteration of this loop determines a reflection G
+*           from the vector V and applies it from left and right to H,
+*           thus creating a nonzero bulge below the subdiagonal.
+*
+*           Each subsequent iteration determines a reflection G to
+*           restore the Hessenberg form in the (K-1)th column, and thus
+*           chases the bulge one step toward the bottom of the active
+*           submatrix. NR is the order of G.
+*
+            NR = MIN( 3, I-K+1 )
+            IF( K.GT.M )
+     $         CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
+            CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
+            IF( K.GT.M ) THEN
+               H( K, K-1 ) = V( 1 )
+               H( K+1, K-1 ) = ZERO
+               IF( K.LT.I-1 )
+     $            H( K+2, K-1 ) = ZERO
+            ELSE IF( M.GT.L ) THEN
+               H( K, K-1 ) = -H( K, K-1 )
+            END IF
+            V2 = V( 2 )
+            T2 = T1*V2
+            IF( NR.EQ.3 ) THEN
+               V3 = V( 3 )
+               T3 = T1*V3
+*
+*              Apply G from the left to transform the rows of the matrix
+*              in columns K to I2.
+*
+               DO 70 J = K, I2
+                  SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
+                  H( K, J ) = H( K, J ) - SUM*T1
+                  H( K+1, J ) = H( K+1, J ) - SUM*T2
+                  H( K+2, J ) = H( K+2, J ) - SUM*T3
+   70          CONTINUE
+*
+*              Apply G from the right to transform the columns of the
+*              matrix in rows I1 to min(K+3,I).
+*
+               DO 80 J = I1, MIN( K+3, I )
+                  SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
+                  H( J, K ) = H( J, K ) - SUM*T1
+                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+                  H( J, K+2 ) = H( J, K+2 ) - SUM*T3
+   80          CONTINUE
+*
+               IF( WANTZ ) THEN
+*
+*                 Accumulate transformations in the matrix Z
+*
+                  DO 90 J = ILOZ, IHIZ
+                     SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
+                     Z( J, K ) = Z( J, K ) - SUM*T1
+                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+                     Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
+   90             CONTINUE
+               END IF
+            ELSE IF( NR.EQ.2 ) THEN
+*
+*              Apply G from the left to transform the rows of the matrix
+*              in columns K to I2.
+*
+               DO 100 J = K, I2
+                  SUM = H( K, J ) + V2*H( K+1, J )
+                  H( K, J ) = H( K, J ) - SUM*T1
+                  H( K+1, J ) = H( K+1, J ) - SUM*T2
+  100          CONTINUE
+*
+*              Apply G from the right to transform the columns of the
+*              matrix in rows I1 to min(K+3,I).
+*
+               DO 110 J = I1, I
+                  SUM = H( J, K ) + V2*H( J, K+1 )
+                  H( J, K ) = H( J, K ) - SUM*T1
+                  H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+  110          CONTINUE
+*
+               IF( WANTZ ) THEN
+*
+*                 Accumulate transformations in the matrix Z
+*
+                  DO 120 J = ILOZ, IHIZ
+                     SUM = Z( J, K ) + V2*Z( J, K+1 )
+                     Z( J, K ) = Z( J, K ) - SUM*T1
+                     Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+  120             CONTINUE
+               END IF
+            END IF
+  130    CONTINUE
+*
+  140 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  150 CONTINUE
+*
+      IF( L.EQ.I ) THEN
+*
+*        H(I,I-1) is negligible: one eigenvalue has converged.
+*
+         WR( I ) = H( I, I )
+         WI( I ) = ZERO
+      ELSE IF( L.EQ.I-1 ) THEN
+*
+*        H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
+*
+*        Transform the 2-by-2 submatrix to standard Schur form,
+*        and compute and store the eigenvalues.
+*
+         CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
+     $                H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
+     $                CS, SN )
+*
+         IF( WANTT ) THEN
+*
+*           Apply the transformation to the rest of H.
+*
+            IF( I2.GT.I )
+     $         CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
+     $                    CS, SN )
+            CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
+         END IF
+         IF( WANTZ ) THEN
+*
+*           Apply the transformation to Z.
+*
+            CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
+         END IF
+      END IF
+*
+*     return to start of the main loop with new value of I.
+*
+      I = L - 1
+      GO TO 20
+*
+  160 CONTINUE
+      RETURN
+*
+*     End of DLAHQR
+*
+      END
diff --git a/src/lib/lapack/dlahr2.f b/src/lib/lapack/dlahr2.f
new file mode 100644
index 00000000..6af74977
--- /dev/null
+++ b/src/lib/lapack/dlahr2.f
@@ -0,0 +1,238 @@
+      SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            K, LDA, LDT, LDY, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION  A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
+*  matrix A so that elements below the k-th subdiagonal are zero. The
+*  reduction is performed by an orthogonal similarity transformation
+*  Q' * A * Q. The routine returns the matrices V and T which determine
+*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+*  This is an auxiliary routine called by DGEHRD.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  K       (input) INTEGER
+*          The offset for the reduction. Elements below the k-th
+*          subdiagonal in the first NB columns are reduced to zero.
+*          K < N.
+*
+*  NB      (input) INTEGER
+*          The number of columns to be reduced.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
+*          On entry, the n-by-(n-k+1) general matrix A.
+*          On exit, the elements on and above the k-th subdiagonal in
+*          the first NB columns are overwritten with the corresponding
+*          elements of the reduced matrix; the elements below the k-th
+*          subdiagonal, with the array TAU, represent the matrix Q as a
+*          product of elementary reflectors. The other columns of A are
+*          unchanged. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) DOUBLE PRECISION array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
+*          The n-by-nb matrix Y.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= N.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of nb elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+*  A(i+k+1:n,i), and tau in TAU(i).
+*
+*  The elements of the vectors v together form the (n-k+1)-by-nb matrix
+*  V which is needed, with T and Y, to apply the transformation to the
+*  unreduced part of the matrix, using an update of the form:
+*  A := (I - V*T*V') * (A - Y*V').
+*
+*  The contents of A on exit are illustrated by the following example
+*  with n = 7, k = 3 and nb = 2:
+*
+*     ( a   a   a   a   a )
+*     ( a   a   a   a   a )
+*     ( a   a   a   a   a )
+*     ( h   h   a   a   a )
+*     ( v1  h   a   a   a )
+*     ( v1  v2  a   a   a )
+*     ( v1  v2  a   a   a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  This file is a slight modification of LAPACK-3.0's DLAHRD
+*  incorporating improvements proposed by Quintana-Orti and Van de
+*  Gejin. Note that the entries of A(1:K,2:NB) differ from those
+*  returned by the original LAPACK routine. This function is
+*  not backward compatible with LAPACK3.0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION  ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, 
+     $                     ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION  EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DLACPY,
+     $                   DLARFG, DSCAL, DTRMM, DTRMV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      DO 10 I = 1, NB
+         IF( I.GT.1 ) THEN
+*
+*           Update A(K+1:N,I)
+*
+*           Update I-th column of A - Y * V'
+*
+            CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
+     $                  A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
+*
+*           Apply I - V * T' * V' to this column (call it b) from the
+*           left, using the last column of T as workspace
+*
+*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
+*                    ( V2 )             ( b2 )
+*
+*           where V1 is unit lower triangular
+*
+*           w := V1' * b1
+*
+            CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL DTRMV( 'Lower', 'Transpose', 'UNIT', 
+     $                  I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL DGEMV( 'Transpose', N-K-I+1, I-1, 
+     $                  ONE, A( K+I, 1 ),
+     $                  LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+*           w := T'*w
+*
+            CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT', 
+     $                  I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, 
+     $                  A( K+I, 1 ),
+     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+*           b1 := b1 - V1*w
+*
+            CALL DTRMV( 'Lower', 'NO TRANSPOSE', 
+     $                  'UNIT', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+            A( K+I-1, I-1 ) = EI
+         END IF
+*
+*        Generate the elementary reflector H(I) to annihilate
+*        A(K+I+1:N,I)
+*
+         CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+     $                TAU( I ) )
+         EI = A( K+I, I )
+         A( K+I, I ) = ONE
+*
+*        Compute  Y(K+1:N,I)
+*
+         CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, 
+     $               ONE, A( K+1, I+1 ),
+     $               LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
+         CALL DGEMV( 'Transpose', N-K-I+1, I-1, 
+     $               ONE, A( K+I, 1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+         CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, 
+     $               Y( K+1, 1 ), LDY,
+     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+         CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+*        Compute T(1:I,I)
+*
+         CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT', 
+     $               I-1, T, LDT,
+     $               T( 1, I ), 1 )
+         T( I, I ) = TAU( I )
+*
+   10 CONTINUE
+      A( K+NB, NB ) = EI
+*
+*     Compute Y(1:K,1:NB)
+*
+      CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+      CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', 
+     $            'UNIT', K, NB,
+     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
+      IF( N.GT.K+NB )
+     $   CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, 
+     $               NB, N-K-NB, ONE,
+     $               A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
+     $               LDY )
+      CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', 
+     $            'NON-UNIT', K, NB,
+     $            ONE, T, LDT, Y, LDY )
+*
+      RETURN
+*
+*     End of DLAHR2
+*
+      END
diff --git a/src/lib/lapack/dlahrd.f b/src/lib/lapack/dlahrd.f
new file mode 100644
index 00000000..a04133d1
--- /dev/null
+++ b/src/lib/lapack/dlahrd.f
@@ -0,0 +1,207 @@
+      SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            K, LDA, LDT, LDY, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
+*  matrix A so that elements below the k-th subdiagonal are zero. The
+*  reduction is performed by an orthogonal similarity transformation
+*  Q' * A * Q. The routine returns the matrices V and T which determine
+*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+*  This is an OBSOLETE auxiliary routine. 
+*  This routine will be 'deprecated' in a  future release.
+*  Please use the new routine DLAHR2 instead.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  K       (input) INTEGER
+*          The offset for the reduction. Elements below the k-th
+*          subdiagonal in the first NB columns are reduced to zero.
+*
+*  NB      (input) INTEGER
+*          The number of columns to be reduced.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
+*          On entry, the n-by-(n-k+1) general matrix A.
+*          On exit, the elements on and above the k-th subdiagonal in
+*          the first NB columns are overwritten with the corresponding
+*          elements of the reduced matrix; the elements below the k-th
+*          subdiagonal, with the array TAU, represent the matrix Q as a
+*          product of elementary reflectors. The other columns of A are
+*          unchanged. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) DOUBLE PRECISION array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
+*          The n-by-nb matrix Y.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= N.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of nb elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+*  A(i+k+1:n,i), and tau in TAU(i).
+*
+*  The elements of the vectors v together form the (n-k+1)-by-nb matrix
+*  V which is needed, with T and Y, to apply the transformation to the
+*  unreduced part of the matrix, using an update of the form:
+*  A := (I - V*T*V') * (A - Y*V').
+*
+*  The contents of A on exit are illustrated by the following example
+*  with n = 7, k = 3 and nb = 2:
+*
+*     ( a   h   a   a   a )
+*     ( a   h   a   a   a )
+*     ( a   h   a   a   a )
+*     ( h   h   a   a   a )
+*     ( v1  h   a   a   a )
+*     ( v1  v2  a   a   a )
+*     ( v1  v2  a   a   a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      DO 10 I = 1, NB
+         IF( I.GT.1 ) THEN
+*
+*           Update A(1:n,i)
+*
+*           Compute i-th column of A - Y * V'
+*
+            CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
+     $                  A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
+*
+*           Apply I - V * T' * V' to this column (call it b) from the
+*           left, using the last column of T as workspace
+*
+*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
+*                    ( V2 )             ( b2 )
+*
+*           where V1 is unit lower triangular
+*
+*           w := V1' * b1
+*
+            CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ),
+     $                  LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+*           w := T'*w
+*
+            CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
+     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+*           b1 := b1 - V1*w
+*
+            CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+            A( K+I-1, I-1 ) = EI
+         END IF
+*
+*        Generate the elementary reflector H(i) to annihilate
+*        A(k+i+1:n,i)
+*
+         CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+     $                TAU( I ) )
+         EI = A( K+I, I )
+         A( K+I, I ) = ONE
+*
+*        Compute  Y(1:n,i)
+*
+         CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+         CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+         CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+     $               ONE, Y( 1, I ), 1 )
+         CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+*        Compute T(1:i,i)
+*
+         CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
+     $               T( 1, I ), 1 )
+         T( I, I ) = TAU( I )
+*
+   10 CONTINUE
+      A( K+NB, NB ) = EI
+*
+      RETURN
+*
+*     End of DLAHRD
+*
+      END
diff --git a/src/lib/lapack/dlaic1.f b/src/lib/lapack/dlaic1.f
new file mode 100644
index 00000000..44baece1
--- /dev/null
+++ b/src/lib/lapack/dlaic1.f
@@ -0,0 +1,292 @@
+      SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            J, JOB
+      DOUBLE PRECISION   C, GAMMA, S, SEST, SESTPR
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   W( J ), X( J )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAIC1 applies one step of incremental condition estimation in
+*  its simplest version:
+*
+*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
+*  lower triangular matrix L, such that
+*           twonorm(L*x) = sest
+*  Then DLAIC1 computes sestpr, s, c such that
+*  the vector
+*                  [ s*x ]
+*           xhat = [  c  ]
+*  is an approximate singular vector of
+*                  [ L     0  ]
+*           Lhat = [ w' gamma ]
+*  in the sense that
+*           twonorm(Lhat*xhat) = sestpr.
+*
+*  Depending on JOB, an estimate for the largest or smallest singular
+*  value is computed.
+*
+*  Note that [s c]' and sestpr**2 is an eigenpair of the system
+*
+*      diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]
+*                                            [ gamma ]
+*
+*  where  alpha =  x'*w.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) INTEGER
+*          = 1: an estimate for the largest singular value is computed.
+*          = 2: an estimate for the smallest singular value is computed.
+*
+*  J       (input) INTEGER
+*          Length of X and W
+*
+*  X       (input) DOUBLE PRECISION array, dimension (J)
+*          The j-vector x.
+*
+*  SEST    (input) DOUBLE PRECISION
+*          Estimated singular value of j by j matrix L
+*
+*  W       (input) DOUBLE PRECISION array, dimension (J)
+*          The j-vector w.
+*
+*  GAMMA   (input) DOUBLE PRECISION
+*          The diagonal element gamma.
+*
+*  SESTPR  (output) DOUBLE PRECISION
+*          Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+*  S       (output) DOUBLE PRECISION
+*          Sine needed in forming xhat.
+*
+*  C       (output) DOUBLE PRECISION
+*          Cosine needed in forming xhat.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+      DOUBLE PRECISION   HALF, FOUR
+      PARAMETER          ( HALF = 0.5D0, FOUR = 4.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
+     $                   NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SIGN, SQRT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DDOT, DLAMCH
+      EXTERNAL           DDOT, DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'Epsilon' )
+      ALPHA = DDOT( J, X, 1, W, 1 )
+*
+      ABSALP = ABS( ALPHA )
+      ABSGAM = ABS( GAMMA )
+      ABSEST = ABS( SEST )
+*
+      IF( JOB.EQ.1 ) THEN
+*
+*        Estimating largest singular value
+*
+*        special cases
+*
+         IF( SEST.EQ.ZERO ) THEN
+            S1 = MAX( ABSGAM, ABSALP )
+            IF( S1.EQ.ZERO ) THEN
+               S = ZERO
+               C = ONE
+               SESTPR = ZERO
+            ELSE
+               S = ALPHA / S1
+               C = GAMMA / S1
+               TMP = SQRT( S*S+C*C )
+               S = S / TMP
+               C = C / TMP
+               SESTPR = S1*TMP
+            END IF
+            RETURN
+         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+            S = ONE
+            C = ZERO
+            TMP = MAX( ABSEST, ABSALP )
+            S1 = ABSEST / TMP
+            S2 = ABSALP / TMP
+            SESTPR = TMP*SQRT( S1*S1+S2*S2 )
+            RETURN
+         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+            S1 = ABSGAM
+            S2 = ABSEST
+            IF( S1.LE.S2 ) THEN
+               S = ONE
+               C = ZERO
+               SESTPR = S2
+            ELSE
+               S = ZERO
+               C = ONE
+               SESTPR = S1
+            END IF
+            RETURN
+         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+            S1 = ABSGAM
+            S2 = ABSALP
+            IF( S1.LE.S2 ) THEN
+               TMP = S1 / S2
+               S = SQRT( ONE+TMP*TMP )
+               SESTPR = S2*S
+               C = ( GAMMA / S2 ) / S
+               S = SIGN( ONE, ALPHA ) / S
+            ELSE
+               TMP = S2 / S1
+               C = SQRT( ONE+TMP*TMP )
+               SESTPR = S1*C
+               S = ( ALPHA / S1 ) / C
+               C = SIGN( ONE, GAMMA ) / C
+            END IF
+            RETURN
+         ELSE
+*
+*           normal case
+*
+            ZETA1 = ALPHA / ABSEST
+            ZETA2 = GAMMA / ABSEST
+*
+            B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
+            C = ZETA1*ZETA1
+            IF( B.GT.ZERO ) THEN
+               T = C / ( B+SQRT( B*B+C ) )
+            ELSE
+               T = SQRT( B*B+C ) - B
+            END IF
+*
+            SINE = -ZETA1 / T
+            COSINE = -ZETA2 / ( ONE+T )
+            TMP = SQRT( SINE*SINE+COSINE*COSINE )
+            S = SINE / TMP
+            C = COSINE / TMP
+            SESTPR = SQRT( T+ONE )*ABSEST
+            RETURN
+         END IF
+*
+      ELSE IF( JOB.EQ.2 ) THEN
+*
+*        Estimating smallest singular value
+*
+*        special cases
+*
+         IF( SEST.EQ.ZERO ) THEN
+            SESTPR = ZERO
+            IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
+               SINE = ONE
+               COSINE = ZERO
+            ELSE
+               SINE = -GAMMA
+               COSINE = ALPHA
+            END IF
+            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
+            S = SINE / S1
+            C = COSINE / S1
+            TMP = SQRT( S*S+C*C )
+            S = S / TMP
+            C = C / TMP
+            RETURN
+         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+            S = ZERO
+            C = ONE
+            SESTPR = ABSGAM
+            RETURN
+         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+            S1 = ABSGAM
+            S2 = ABSEST
+            IF( S1.LE.S2 ) THEN
+               S = ZERO
+               C = ONE
+               SESTPR = S1
+            ELSE
+               S = ONE
+               C = ZERO
+               SESTPR = S2
+            END IF
+            RETURN
+         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+            S1 = ABSGAM
+            S2 = ABSALP
+            IF( S1.LE.S2 ) THEN
+               TMP = S1 / S2
+               C = SQRT( ONE+TMP*TMP )
+               SESTPR = ABSEST*( TMP / C )
+               S = -( GAMMA / S2 ) / C
+               C = SIGN( ONE, ALPHA ) / C
+            ELSE
+               TMP = S2 / S1
+               S = SQRT( ONE+TMP*TMP )
+               SESTPR = ABSEST / S
+               C = ( ALPHA / S1 ) / S
+               S = -SIGN( ONE, GAMMA ) / S
+            END IF
+            RETURN
+         ELSE
+*
+*           normal case
+*
+            ZETA1 = ALPHA / ABSEST
+            ZETA2 = GAMMA / ABSEST
+*
+            NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
+     $              ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
+*
+*           See if root is closer to zero or to ONE
+*
+            TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
+            IF( TEST.GE.ZERO ) THEN
+*
+*              root is close to zero, compute directly
+*
+               B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
+               C = ZETA2*ZETA2
+               T = C / ( B+SQRT( ABS( B*B-C ) ) )
+               SINE = ZETA1 / ( ONE-T )
+               COSINE = -ZETA2 / T
+               SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
+            ELSE
+*
+*              root is closer to ONE, shift by that amount
+*
+               B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
+               C = ZETA1*ZETA1
+               IF( B.GE.ZERO ) THEN
+                  T = -C / ( B+SQRT( B*B+C ) )
+               ELSE
+                  T = B - SQRT( B*B+C )
+               END IF
+               SINE = -ZETA1 / T
+               COSINE = -ZETA2 / ( ONE+T )
+               SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
+            END IF
+            TMP = SQRT( SINE*SINE+COSINE*COSINE )
+            S = SINE / TMP
+            C = COSINE / TMP
+            RETURN
+*
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLAIC1
+*
+      END
diff --git a/src/lib/lapack/dlaisnan.f b/src/lib/lapack/dlaisnan.f
new file mode 100644
index 00000000..96350a27
--- /dev/null
+++ b/src/lib/lapack/dlaisnan.f
@@ -0,0 +1,41 @@
+      LOGICAL FUNCTION DLAISNAN(DIN1,DIN2)
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION DIN1,DIN2
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is not for general use.  It exists solely to avoid
+*  over-optimization in DISNAN.
+*
+*  DLAISNAN checks for NaNs by comparing its two arguments for
+*  inequality.  NaN is the only floating-point value where NaN != NaN
+*  returns .TRUE.  To check for NaNs, pass the same variable as both
+*  arguments.
+*
+*  Strictly speaking, Fortran does not allow aliasing of function
+*  arguments. So a compiler must assume that the two arguments are
+*  not the same variable, and the test will not be optimized away.
+*  Interprocedural or whole-program optimization may delete this
+*  test.  The ISNAN functions will be replaced by the correct
+*  Fortran 03 intrinsic once the intrinsic is widely available.
+*
+*  Arguments
+*  =========
+*
+*  DIN1     (input) DOUBLE PRECISION
+*  DIN2     (input) DOUBLE PRECISION
+*          Two numbers to compare for inequality.
+*
+*  =====================================================================
+*
+*  .. Executable Statements ..
+      DLAISNAN = (DIN1.NE.DIN2)
+      RETURN
+      END
diff --git a/src/lib/lapack/dlaln2.f b/src/lib/lapack/dlaln2.f
new file mode 100644
index 00000000..7c99bdbe
--- /dev/null
+++ b/src/lib/lapack/dlaln2.f
@@ -0,0 +1,507 @@
+      SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
+     $                   LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            LTRANS
+      INTEGER            INFO, LDA, LDB, LDX, NA, NW
+      DOUBLE PRECISION   CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLALN2 solves a system of the form  (ca A - w D ) X = s B
+*  or (ca A' - w D) X = s B   with possible scaling ("s") and
+*  perturbation of A.  (A' means A-transpose.)
+*
+*  A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
+*  real diagonal matrix, w is a real or complex value, and X and B are
+*  NA x 1 matrices -- real if w is real, complex if w is complex.  NA
+*  may be 1 or 2.
+*
+*  If w is complex, X and B are represented as NA x 2 matrices,
+*  the first column of each being the real part and the second
+*  being the imaginary part.
+*
+*  "s" is a scaling factor (.LE. 1), computed by DLALN2, which is
+*  so chosen that X can be computed without overflow.  X is further
+*  scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
+*  than overflow.
+*
+*  If both singular values of (ca A - w D) are less than SMIN,
+*  SMIN*identity will be used instead of (ca A - w D).  If only one
+*  singular value is less than SMIN, one element of (ca A - w D) will be
+*  perturbed enough to make the smallest singular value roughly SMIN.
+*  If both singular values are at least SMIN, (ca A - w D) will not be
+*  perturbed.  In any case, the perturbation will be at most some small
+*  multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values
+*  are computed by infinity-norm approximations, and thus will only be
+*  correct to a factor of 2 or so.
+*
+*  Note: all input quantities are assumed to be smaller than overflow
+*  by a reasonable factor.  (See BIGNUM.)
+*
+*  Arguments
+*  ==========
+*
+*  LTRANS  (input) LOGICAL
+*          =.TRUE.:  A-transpose will be used.
+*          =.FALSE.: A will be used (not transposed.)
+*
+*  NA      (input) INTEGER
+*          The size of the matrix A.  It may (only) be 1 or 2.
+*
+*  NW      (input) INTEGER
+*          1 if "w" is real, 2 if "w" is complex.  It may only be 1
+*          or 2.
+*
+*  SMIN    (input) DOUBLE PRECISION
+*          The desired lower bound on the singular values of A.  This
+*          should be a safe distance away from underflow or overflow,
+*          say, between (underflow/machine precision) and  (machine
+*          precision * overflow ).  (See BIGNUM and ULP.)
+*
+*  CA      (input) DOUBLE PRECISION
+*          The coefficient c, which A is multiplied by.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,NA)
+*          The NA x NA matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  It must be at least NA.
+*
+*  D1      (input) DOUBLE PRECISION
+*          The 1,1 element in the diagonal matrix D.
+*
+*  D2      (input) DOUBLE PRECISION
+*          The 2,2 element in the diagonal matrix D.  Not used if NW=1.
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,NW)
+*          The NA x NW matrix B (right-hand side).  If NW=2 ("w" is
+*          complex), column 1 contains the real part of B and column 2
+*          contains the imaginary part.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  It must be at least NA.
+*
+*  WR      (input) DOUBLE PRECISION
+*          The real part of the scalar "w".
+*
+*  WI      (input) DOUBLE PRECISION
+*          The imaginary part of the scalar "w".  Not used if NW=1.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (LDX,NW)
+*          The NA x NW matrix X (unknowns), as computed by DLALN2.
+*          If NW=2 ("w" is complex), on exit, column 1 will contain
+*          the real part of X and column 2 will contain the imaginary
+*          part.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of X.  It must be at least NA.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          The scale factor that B must be multiplied by to insure
+*          that overflow does not occur when computing X.  Thus,
+*          (ca A - w D) X  will be SCALE*B, not B (ignoring
+*          perturbations of A.)  It will be at most 1.
+*
+*  XNORM   (output) DOUBLE PRECISION
+*          The infinity-norm of X, when X is regarded as an NA x NW
+*          real matrix.
+*
+*  INFO    (output) INTEGER
+*          An error flag.  It will be set to zero if no error occurs,
+*          a negative number if an argument is in error, or a positive
+*          number if  ca A - w D  had to be perturbed.
+*          The possible values are:
+*          = 0: No error occurred, and (ca A - w D) did not have to be
+*                 perturbed.
+*          = 1: (ca A - w D) had to be perturbed to make its smallest
+*               (or only) singular value greater than SMIN.
+*          NOTE: In the interests of speed, this routine does not
+*                check the inputs for errors.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ICMAX, J
+      DOUBLE PRECISION   BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
+     $                   CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
+     $                   LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
+     $                   UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
+     $                   UR22, XI1, XI2, XR1, XR2
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            RSWAP( 4 ), ZSWAP( 4 )
+      INTEGER            IPIVOT( 4, 4 )
+      DOUBLE PRECISION   CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Equivalences ..
+      EQUIVALENCE        ( CI( 1, 1 ), CIV( 1 ) ),
+     $                   ( CR( 1, 1 ), CRV( 1 ) )
+*     ..
+*     .. Data statements ..
+      DATA               ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
+      DATA               RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
+      DATA               IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
+     $                   3, 2, 1 /
+*     ..
+*     .. Executable Statements ..
+*
+*     Compute BIGNUM
+*
+      SMLNUM = TWO*DLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SMLNUM
+      SMINI = MAX( SMIN, SMLNUM )
+*
+*     Don't check for input errors
+*
+      INFO = 0
+*
+*     Standard Initializations
+*
+      SCALE = ONE
+*
+      IF( NA.EQ.1 ) THEN
+*
+*        1 x 1  (i.e., scalar) system   C X = B
+*
+         IF( NW.EQ.1 ) THEN
+*
+*           Real 1x1 system.
+*
+*           C = ca A - w D
+*
+            CSR = CA*A( 1, 1 ) - WR*D1
+            CNORM = ABS( CSR )
+*
+*           If | C | < SMINI, use C = SMINI
+*
+            IF( CNORM.LT.SMINI ) THEN
+               CSR = SMINI
+               CNORM = SMINI
+               INFO = 1
+            END IF
+*
+*           Check scaling for  X = B / C
+*
+            BNORM = ABS( B( 1, 1 ) )
+            IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+               IF( BNORM.GT.BIGNUM*CNORM )
+     $            SCALE = ONE / BNORM
+            END IF
+*
+*           Compute X
+*
+            X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
+            XNORM = ABS( X( 1, 1 ) )
+         ELSE
+*
+*           Complex 1x1 system (w is complex)
+*
+*           C = ca A - w D
+*
+            CSR = CA*A( 1, 1 ) - WR*D1
+            CSI = -WI*D1
+            CNORM = ABS( CSR ) + ABS( CSI )
+*
+*           If | C | < SMINI, use C = SMINI
+*
+            IF( CNORM.LT.SMINI ) THEN
+               CSR = SMINI
+               CSI = ZERO
+               CNORM = SMINI
+               INFO = 1
+            END IF
+*
+*           Check scaling for  X = B / C
+*
+            BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
+            IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+               IF( BNORM.GT.BIGNUM*CNORM )
+     $            SCALE = ONE / BNORM
+            END IF
+*
+*           Compute X
+*
+            CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI,
+     $                   X( 1, 1 ), X( 1, 2 ) )
+            XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+         END IF
+*
+      ELSE
+*
+*        2x2 System
+*
+*        Compute the real part of  C = ca A - w D  (or  ca A' - w D )
+*
+         CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
+         CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
+         IF( LTRANS ) THEN
+            CR( 1, 2 ) = CA*A( 2, 1 )
+            CR( 2, 1 ) = CA*A( 1, 2 )
+         ELSE
+            CR( 2, 1 ) = CA*A( 2, 1 )
+            CR( 1, 2 ) = CA*A( 1, 2 )
+         END IF
+*
+         IF( NW.EQ.1 ) THEN
+*
+*           Real 2x2 system  (w is real)
+*
+*           Find the largest element in C
+*
+            CMAX = ZERO
+            ICMAX = 0
+*
+            DO 10 J = 1, 4
+               IF( ABS( CRV( J ) ).GT.CMAX ) THEN
+                  CMAX = ABS( CRV( J ) )
+                  ICMAX = J
+               END IF
+   10       CONTINUE
+*
+*           If norm(C) < SMINI, use SMINI*identity.
+*
+            IF( CMAX.LT.SMINI ) THEN
+               BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
+               IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+                  IF( BNORM.GT.BIGNUM*SMINI )
+     $               SCALE = ONE / BNORM
+               END IF
+               TEMP = SCALE / SMINI
+               X( 1, 1 ) = TEMP*B( 1, 1 )
+               X( 2, 1 ) = TEMP*B( 2, 1 )
+               XNORM = TEMP*BNORM
+               INFO = 1
+               RETURN
+            END IF
+*
+*           Gaussian elimination with complete pivoting.
+*
+            UR11 = CRV( ICMAX )
+            CR21 = CRV( IPIVOT( 2, ICMAX ) )
+            UR12 = CRV( IPIVOT( 3, ICMAX ) )
+            CR22 = CRV( IPIVOT( 4, ICMAX ) )
+            UR11R = ONE / UR11
+            LR21 = UR11R*CR21
+            UR22 = CR22 - UR12*LR21
+*
+*           If smaller pivot < SMINI, use SMINI
+*
+            IF( ABS( UR22 ).LT.SMINI ) THEN
+               UR22 = SMINI
+               INFO = 1
+            END IF
+            IF( RSWAP( ICMAX ) ) THEN
+               BR1 = B( 2, 1 )
+               BR2 = B( 1, 1 )
+            ELSE
+               BR1 = B( 1, 1 )
+               BR2 = B( 2, 1 )
+            END IF
+            BR2 = BR2 - LR21*BR1
+            BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
+            IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
+               IF( BBND.GE.BIGNUM*ABS( UR22 ) )
+     $            SCALE = ONE / BBND
+            END IF
+*
+            XR2 = ( BR2*SCALE ) / UR22
+            XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
+            IF( ZSWAP( ICMAX ) ) THEN
+               X( 1, 1 ) = XR2
+               X( 2, 1 ) = XR1
+            ELSE
+               X( 1, 1 ) = XR1
+               X( 2, 1 ) = XR2
+            END IF
+            XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
+*
+*           Further scaling if  norm(A) norm(X) > overflow
+*
+            IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+               IF( XNORM.GT.BIGNUM / CMAX ) THEN
+                  TEMP = CMAX / BIGNUM
+                  X( 1, 1 ) = TEMP*X( 1, 1 )
+                  X( 2, 1 ) = TEMP*X( 2, 1 )
+                  XNORM = TEMP*XNORM
+                  SCALE = TEMP*SCALE
+               END IF
+            END IF
+         ELSE
+*
+*           Complex 2x2 system  (w is complex)
+*
+*           Find the largest element in C
+*
+            CI( 1, 1 ) = -WI*D1
+            CI( 2, 1 ) = ZERO
+            CI( 1, 2 ) = ZERO
+            CI( 2, 2 ) = -WI*D2
+            CMAX = ZERO
+            ICMAX = 0
+*
+            DO 20 J = 1, 4
+               IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
+                  CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
+                  ICMAX = J
+               END IF
+   20       CONTINUE
+*
+*           If norm(C) < SMINI, use SMINI*identity.
+*
+            IF( CMAX.LT.SMINI ) THEN
+               BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+     $                 ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+               IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+                  IF( BNORM.GT.BIGNUM*SMINI )
+     $               SCALE = ONE / BNORM
+               END IF
+               TEMP = SCALE / SMINI
+               X( 1, 1 ) = TEMP*B( 1, 1 )
+               X( 2, 1 ) = TEMP*B( 2, 1 )
+               X( 1, 2 ) = TEMP*B( 1, 2 )
+               X( 2, 2 ) = TEMP*B( 2, 2 )
+               XNORM = TEMP*BNORM
+               INFO = 1
+               RETURN
+            END IF
+*
+*           Gaussian elimination with complete pivoting.
+*
+            UR11 = CRV( ICMAX )
+            UI11 = CIV( ICMAX )
+            CR21 = CRV( IPIVOT( 2, ICMAX ) )
+            CI21 = CIV( IPIVOT( 2, ICMAX ) )
+            UR12 = CRV( IPIVOT( 3, ICMAX ) )
+            UI12 = CIV( IPIVOT( 3, ICMAX ) )
+            CR22 = CRV( IPIVOT( 4, ICMAX ) )
+            CI22 = CIV( IPIVOT( 4, ICMAX ) )
+            IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
+*
+*              Code when off-diagonals of pivoted C are real
+*
+               IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
+                  TEMP = UI11 / UR11
+                  UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
+                  UI11R = -TEMP*UR11R
+               ELSE
+                  TEMP = UR11 / UI11
+                  UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
+                  UR11R = -TEMP*UI11R
+               END IF
+               LR21 = CR21*UR11R
+               LI21 = CR21*UI11R
+               UR12S = UR12*UR11R
+               UI12S = UR12*UI11R
+               UR22 = CR22 - UR12*LR21
+               UI22 = CI22 - UR12*LI21
+            ELSE
+*
+*              Code when diagonals of pivoted C are real
+*
+               UR11R = ONE / UR11
+               UI11R = ZERO
+               LR21 = CR21*UR11R
+               LI21 = CI21*UR11R
+               UR12S = UR12*UR11R
+               UI12S = UI12*UR11R
+               UR22 = CR22 - UR12*LR21 + UI12*LI21
+               UI22 = -UR12*LI21 - UI12*LR21
+            END IF
+            U22ABS = ABS( UR22 ) + ABS( UI22 )
+*
+*           If smaller pivot < SMINI, use SMINI
+*
+            IF( U22ABS.LT.SMINI ) THEN
+               UR22 = SMINI
+               UI22 = ZERO
+               INFO = 1
+            END IF
+            IF( RSWAP( ICMAX ) ) THEN
+               BR2 = B( 1, 1 )
+               BR1 = B( 2, 1 )
+               BI2 = B( 1, 2 )
+               BI1 = B( 2, 2 )
+            ELSE
+               BR1 = B( 1, 1 )
+               BR2 = B( 2, 1 )
+               BI1 = B( 1, 2 )
+               BI2 = B( 2, 2 )
+            END IF
+            BR2 = BR2 - LR21*BR1 + LI21*BI1
+            BI2 = BI2 - LI21*BR1 - LR21*BI1
+            BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )*
+     $             ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ),
+     $             ABS( BR2 )+ABS( BI2 ) )
+            IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
+               IF( BBND.GE.BIGNUM*U22ABS ) THEN
+                  SCALE = ONE / BBND
+                  BR1 = SCALE*BR1
+                  BI1 = SCALE*BI1
+                  BR2 = SCALE*BR2
+                  BI2 = SCALE*BI2
+               END IF
+            END IF
+*
+            CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
+            XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
+            XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
+            IF( ZSWAP( ICMAX ) ) THEN
+               X( 1, 1 ) = XR2
+               X( 2, 1 ) = XR1
+               X( 1, 2 ) = XI2
+               X( 2, 2 ) = XI1
+            ELSE
+               X( 1, 1 ) = XR1
+               X( 2, 1 ) = XR2
+               X( 1, 2 ) = XI1
+               X( 2, 2 ) = XI2
+            END IF
+            XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
+*
+*           Further scaling if  norm(A) norm(X) > overflow
+*
+            IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+               IF( XNORM.GT.BIGNUM / CMAX ) THEN
+                  TEMP = CMAX / BIGNUM
+                  X( 1, 1 ) = TEMP*X( 1, 1 )
+                  X( 2, 1 ) = TEMP*X( 2, 1 )
+                  X( 1, 2 ) = TEMP*X( 1, 2 )
+                  X( 2, 2 ) = TEMP*X( 2, 2 )
+                  XNORM = TEMP*XNORM
+                  SCALE = TEMP*SCALE
+               END IF
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLALN2
+*
+      END
diff --git a/src/lib/lapack/dlamch.f b/src/lib/lapack/dlamch.f
new file mode 100644
index 00000000..64ac3bec
--- /dev/null
+++ b/src/lib/lapack/dlamch.f
@@ -0,0 +1,857 @@
+      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      CHARACTER          CMACH
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMCH determines double precision machine parameters.
+*
+*  Arguments
+*  =========
+*
+*  CMACH   (input) CHARACTER*1
+*          Specifies the value to be returned by DLAMCH:
+*          = 'E' or 'e',   DLAMCH := eps
+*          = 'S' or 's ,   DLAMCH := sfmin
+*          = 'B' or 'b',   DLAMCH := base
+*          = 'P' or 'p',   DLAMCH := eps*base
+*          = 'N' or 'n',   DLAMCH := t
+*          = 'R' or 'r',   DLAMCH := rnd
+*          = 'M' or 'm',   DLAMCH := emin
+*          = 'U' or 'u',   DLAMCH := rmin
+*          = 'L' or 'l',   DLAMCH := emax
+*          = 'O' or 'o',   DLAMCH := rmax
+*
+*          where
+*
+*          eps   = relative machine precision
+*          sfmin = safe minimum, such that 1/sfmin does not overflow
+*          base  = base of the machine
+*          prec  = eps*base
+*          t     = number of (base) digits in the mantissa
+*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
+*          emin  = minimum exponent before (gradual) underflow
+*          rmin  = underflow threshold - base**(emin-1)
+*          emax  = largest exponent before overflow
+*          rmax  = overflow threshold  - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LRND
+      INTEGER            BETA, IMAX, IMIN, IT
+      DOUBLE PRECISION   BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+     $                   RND, SFMIN, SMALL, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAMC2
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+     $                   EMAX, RMAX, PREC
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+         BASE = BETA
+         T = IT
+         IF( LRND ) THEN
+            RND = ONE
+            EPS = ( BASE**( 1-IT ) ) / 2
+         ELSE
+            RND = ZERO
+            EPS = BASE**( 1-IT )
+         END IF
+         PREC = EPS*BASE
+         EMIN = IMIN
+         EMAX = IMAX
+         SFMIN = RMIN
+         SMALL = ONE / RMAX
+         IF( SMALL.GE.SFMIN ) THEN
+*
+*           Use SMALL plus a bit, to avoid the possibility of rounding
+*           causing overflow when computing  1/sfmin.
+*
+            SFMIN = SMALL*( ONE+EPS )
+         END IF
+      END IF
+*
+      IF( LSAME( CMACH, 'E' ) ) THEN
+         RMACH = EPS
+      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+         RMACH = SFMIN
+      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+         RMACH = BASE
+      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+         RMACH = PREC
+      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+         RMACH = T
+      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+         RMACH = RND
+      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+         RMACH = EMIN
+      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+         RMACH = RMIN
+      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+         RMACH = EMAX
+      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+         RMACH = RMAX
+      END IF
+*
+      DLAMCH = RMACH
+      RETURN
+*
+*     End of DLAMCH
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE1, RND
+      INTEGER            BETA, T
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC1 determines the machine parameters given by BETA, T, RND, and
+*  IEEE1.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  IEEE1   (output) LOGICAL
+*          Specifies whether rounding appears to be done in the IEEE
+*          'round to nearest' style.
+*
+*  Further Details
+*  ===============
+*
+*  The routine is based on the routine  ENVRON  by Malcolm and
+*  incorporates suggestions by Gentleman and Marovich. See
+*
+*     Malcolm M. A. (1972) Algorithms to reveal properties of
+*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+*        that reveal properties of floating point arithmetic units.
+*        Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LIEEE1, LRND
+      INTEGER            LBETA, LT
+      DOUBLE PRECISION   A, B, C, F, ONE, QTR, SAVEC, T1, T2
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ONE = 1
+*
+*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
+*        IEEE1, T and RND.
+*
+*        Throughout this routine  we use the function  DLAMC3  to ensure
+*        that relevant values are  stored and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        Compute  a = 2.0**m  with the  smallest positive integer m such
+*        that
+*
+*           fl( a + 1.0 ) = a.
+*
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   10    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            A = 2*A
+            C = DLAMC3( A, ONE )
+            C = DLAMC3( C, -A )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+*        Now compute  b = 2.0**m  with the smallest positive integer m
+*        such that
+*
+*           fl( a + b ) .gt. a.
+*
+         B = 1
+         C = DLAMC3( A, B )
+*
+*+       WHILE( C.EQ.A )LOOP
+   20    CONTINUE
+         IF( C.EQ.A ) THEN
+            B = 2*B
+            C = DLAMC3( A, B )
+            GO TO 20
+         END IF
+*+       END WHILE
+*
+*        Now compute the base.  a and c  are neighbouring floating point
+*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
+*        their difference is beta. Adding 0.25 to c is to ensure that it
+*        is truncated to beta and not ( beta - 1 ).
+*
+         QTR = ONE / 4
+         SAVEC = C
+         C = DLAMC3( C, -A )
+         LBETA = C + QTR
+*
+*        Now determine whether rounding or chopping occurs,  by adding a
+*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
+*
+         B = LBETA
+         F = DLAMC3( B / 2, -B / 100 )
+         C = DLAMC3( F, A )
+         IF( C.EQ.A ) THEN
+            LRND = .TRUE.
+         ELSE
+            LRND = .FALSE.
+         END IF
+         F = DLAMC3( B / 2, B / 100 )
+         C = DLAMC3( F, A )
+         IF( ( LRND ) .AND. ( C.EQ.A ) )
+     $      LRND = .FALSE.
+*
+*        Try and decide whether rounding is done in the  IEEE  'round to
+*        nearest' style. B/2 is half a unit in the last place of the two
+*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
+*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
+*        A, but adding B/2 to SAVEC should change SAVEC.
+*
+         T1 = DLAMC3( B / 2, A )
+         T2 = DLAMC3( B / 2, SAVEC )
+         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+*        Now find  the  mantissa, t.  It should  be the  integer part of
+*        log to the base beta of a,  however it is safer to determine  t
+*        by powering.  So we find t as the smallest positive integer for
+*        which
+*
+*           fl( beta**t + 1.0 ) = 1.0.
+*
+         LT = 0
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   30    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            LT = LT + 1
+            A = A*LBETA
+            C = DLAMC3( A, ONE )
+            C = DLAMC3( C, -A )
+            GO TO 30
+         END IF
+*+       END WHILE
+*
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      IEEE1 = LIEEE1
+      RETURN
+*
+*     End of DLAMC1
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            RND
+      INTEGER            BETA, EMAX, EMIN, T
+      DOUBLE PRECISION   EPS, RMAX, RMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC2 determines the machine parameters specified in its argument
+*  list.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  EPS     (output) DOUBLE PRECISION
+*          The smallest positive number such that
+*
+*             fl( 1.0 - EPS ) .LT. 1.0,
+*
+*          where fl denotes the computed value.
+*
+*  EMIN    (output) INTEGER
+*          The minimum exponent before (gradual) underflow occurs.
+*
+*  RMIN    (output) DOUBLE PRECISION
+*          The smallest normalized number for the machine, given by
+*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
+*          of BETA.
+*
+*  EMAX    (output) INTEGER
+*          The maximum exponent before overflow occurs.
+*
+*  RMAX    (output) DOUBLE PRECISION
+*          The largest positive number for the machine, given by
+*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
+*          value of BETA.
+*
+*  Further Details
+*  ===============
+*
+*  The computation of  EPS  is based on a routine PARANOIA by
+*  W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
+      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+     $                   NGNMIN, NGPMIN
+      DOUBLE PRECISION   A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+     $                   SIXTH, SMALL, THIRD, TWO, ZERO
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAMC1, DLAMC4, DLAMC5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+     $                   LRMIN, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ZERO = 0
+         ONE = 1
+         TWO = 2
+*
+*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
+*        BETA, T, RND, EPS, EMIN and RMIN.
+*
+*        Throughout this routine  we use the function  DLAMC3  to ensure
+*        that relevant values are stored  and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        DLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
+*
+         CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+*        Start to find EPS.
+*
+         B = LBETA
+         A = B**( -LT )
+         LEPS = A
+*
+*        Try some tricks to see whether or not this is the correct  EPS.
+*
+         B = TWO / 3
+         HALF = ONE / 2
+         SIXTH = DLAMC3( B, -HALF )
+         THIRD = DLAMC3( SIXTH, SIXTH )
+         B = DLAMC3( THIRD, -HALF )
+         B = DLAMC3( B, SIXTH )
+         B = ABS( B )
+         IF( B.LT.LEPS )
+     $      B = LEPS
+*
+         LEPS = 1
+*
+*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+   10    CONTINUE
+         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+            LEPS = B
+            C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+            C = DLAMC3( HALF, -C )
+            B = DLAMC3( HALF, C )
+            C = DLAMC3( HALF, -B )
+            B = DLAMC3( HALF, C )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+         IF( A.LT.LEPS )
+     $      LEPS = A
+*
+*        Computation of EPS complete.
+*
+*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
+*        Keep dividing  A by BETA until (gradual) underflow occurs. This
+*        is detected when we cannot recover the previous A.
+*
+         RBASE = ONE / LBETA
+         SMALL = ONE
+         DO 20 I = 1, 3
+            SMALL = DLAMC3( SMALL*RBASE, ZERO )
+   20    CONTINUE
+         A = DLAMC3( ONE, SMALL )
+         CALL DLAMC4( NGPMIN, ONE, LBETA )
+         CALL DLAMC4( NGNMIN, -ONE, LBETA )
+         CALL DLAMC4( GPMIN, A, LBETA )
+         CALL DLAMC4( GNMIN, -A, LBETA )
+         IEEE = .FALSE.
+*
+         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( NGPMIN.EQ.GPMIN ) THEN
+               LEMIN = NGPMIN
+*            ( Non twos-complement machines, no gradual underflow;
+*              e.g.,  VAX )
+            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+               LEMIN = NGPMIN - 1 + LT
+               IEEE = .TRUE.
+*            ( Non twos-complement machines, with gradual underflow;
+*              e.g., IEEE standard followers )
+            ELSE
+               LEMIN = MIN( NGPMIN, GPMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN )
+*            ( Twos-complement machines, no gradual underflow;
+*              e.g., CYBER 205 )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+     $            ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+*            ( Twos-complement machines with gradual underflow;
+*              no known machine )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE
+            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+*         ( A guess; no known machine )
+            IWARN = .TRUE.
+         END IF
+***
+* Comment out this if block if EMIN is ok
+         IF( IWARN ) THEN
+            FIRST = .TRUE.
+            WRITE( 6, FMT = 9999 )LEMIN
+         END IF
+***
+*
+*        Assume IEEE arithmetic if we found denormalised  numbers above,
+*        or if arithmetic seems to round in the  IEEE style,  determined
+*        in routine DLAMC1. A true IEEE machine should have both  things
+*        true; however, faulty machines may have one or the other.
+*
+         IEEE = IEEE .OR. LIEEE1
+*
+*        Compute  RMIN by successive division by  BETA. We could compute
+*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
+*        this computation.
+*
+         LRMIN = 1
+         DO 30 I = 1, 1 - LEMIN
+            LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
+   30    CONTINUE
+*
+*        Finally, call DLAMC5 to compute EMAX and RMAX.
+*
+         CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      EPS = LEPS
+      EMIN = LEMIN
+      RMIN = LRMIN
+      EMAX = LEMAX
+      RMAX = LRMAX
+*
+      RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+     $      '  EMIN = ', I8, /
+     $      ' If, after inspection, the value EMIN looks',
+     $      ' acceptable please comment out ',
+     $      / ' the IF block as marked within the code of routine',
+     $      ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+*     End of DLAMC2
+*
+      END
+*
+************************************************************************
+*
+      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC3  is intended to force  A  and  B  to be stored prior to doing
+*  the addition of  A  and  B ,  for use in situations where optimizers
+*  might hold one of these in a register.
+*
+*  Arguments
+*  =========
+*
+*  A, B    (input) DOUBLE PRECISION
+*          The values A and B.
+*
+* =====================================================================
+*
+*     .. Executable Statements ..
+*
+      DLAMC3 = A + B
+*
+      RETURN
+*
+*     End of DLAMC3
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC4( EMIN, START, BASE )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            BASE, EMIN
+      DOUBLE PRECISION   START
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC4 is a service routine for DLAMC2.
+*
+*  Arguments
+*  =========
+*
+*  EMIN    (output) EMIN
+*          The minimum exponent before (gradual) underflow, computed by
+*          setting A = START and dividing by BASE until the previous A
+*          can not be recovered.
+*
+*  START   (input) DOUBLE PRECISION
+*          The starting point for determining EMIN.
+*
+*  BASE    (input) INTEGER
+*          The base of the machine.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Executable Statements ..
+*
+      A = START
+      ONE = 1
+      RBASE = ONE / BASE
+      ZERO = 0
+      EMIN = 1
+      B1 = DLAMC3( A*RBASE, ZERO )
+      C1 = A
+      C2 = A
+      D1 = A
+      D2 = A
+*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
+   10 CONTINUE
+      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+     $    ( D2.EQ.A ) ) THEN
+         EMIN = EMIN - 1
+         A = B1
+         B1 = DLAMC3( A / BASE, ZERO )
+         C1 = DLAMC3( B1*BASE, ZERO )
+         D1 = ZERO
+         DO 20 I = 1, BASE
+            D1 = D1 + B1
+   20    CONTINUE
+         B2 = DLAMC3( A*RBASE, ZERO )
+         C2 = DLAMC3( B2 / RBASE, ZERO )
+         D2 = ZERO
+         DO 30 I = 1, BASE
+            D2 = D2 + B2
+   30    CONTINUE
+         GO TO 10
+      END IF
+*+    END WHILE
+*
+      RETURN
+*
+*     End of DLAMC4
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            BETA, EMAX, EMIN, P
+      DOUBLE PRECISION   RMAX
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAMC5 attempts to compute RMAX, the largest machine floating-point
+*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
+*  approximately to a power of 2.  It will fail on machines where this
+*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
+*  too large (i.e. too close to zero), probably with overflow.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (input) INTEGER
+*          The base of floating-point arithmetic.
+*
+*  P       (input) INTEGER
+*          The number of base BETA digits in the mantissa of a
+*          floating-point value.
+*
+*  EMIN    (input) INTEGER
+*          The minimum exponent before (gradual) underflow.
+*
+*  IEEE    (input) LOGICAL
+*          A logical flag specifying whether or not the arithmetic
+*          system is thought to comply with the IEEE standard.
+*
+*  EMAX    (output) INTEGER
+*          The largest exponent before overflow
+*
+*  RMAX    (output) DOUBLE PRECISION
+*          The largest machine floating-point number.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+      DOUBLE PRECISION   OLDY, RECBAS, Y, Z
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMC3
+      EXTERNAL           DLAMC3
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     First compute LEXP and UEXP, two powers of 2 that bound
+*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+*     approximately to the bound that is closest to abs(EMIN).
+*     (EMAX is the exponent of the required number RMAX).
+*
+      LEXP = 1
+      EXBITS = 1
+   10 CONTINUE
+      TRY = LEXP*2
+      IF( TRY.LE.( -EMIN ) ) THEN
+         LEXP = TRY
+         EXBITS = EXBITS + 1
+         GO TO 10
+      END IF
+      IF( LEXP.EQ.-EMIN ) THEN
+         UEXP = LEXP
+      ELSE
+         UEXP = TRY
+         EXBITS = EXBITS + 1
+      END IF
+*
+*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+*     than or equal to EMIN. EXBITS is the number of bits needed to
+*     store the exponent.
+*
+      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+         EXPSUM = 2*LEXP
+      ELSE
+         EXPSUM = 2*UEXP
+      END IF
+*
+*     EXPSUM is the exponent range, approximately equal to
+*     EMAX - EMIN + 1 .
+*
+      EMAX = EXPSUM + EMIN - 1
+      NBITS = 1 + EXBITS + P
+*
+*     NBITS is the total number of bits needed to store a
+*     floating-point number.
+*
+      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+*        Either there are an odd number of bits used to store a
+*        floating-point number, which is unlikely, or some bits are
+*        not used in the representation of numbers, which is possible,
+*        (e.g. Cray machines) or the mantissa has an implicit bit,
+*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+*        most likely. We have to assume the last alternative.
+*        If this is true, then we need to reduce EMAX by one because
+*        there must be some way of representing zero in an implicit-bit
+*        system. On machines like Cray, we are reducing EMAX by one
+*        unnecessarily.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+      IF( IEEE ) THEN
+*
+*        Assume we are on an IEEE machine which reserves one exponent
+*        for infinity and NaN.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+*     Now create RMAX, the largest machine number, which should
+*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+*     First compute 1.0 - BETA**(-P), being careful that the
+*     result is less than 1.0 .
+*
+      RECBAS = ONE / BETA
+      Z = BETA - ONE
+      Y = ZERO
+      DO 20 I = 1, P
+         Z = Z*RECBAS
+         IF( Y.LT.ONE )
+     $      OLDY = Y
+         Y = DLAMC3( Y, Z )
+   20 CONTINUE
+      IF( Y.GE.ONE )
+     $   Y = OLDY
+*
+*     Now multiply by BETA**EMAX to get RMAX.
+*
+      DO 30 I = 1, EMAX
+         Y = DLAMC3( Y*BETA, ZERO )
+   30 CONTINUE
+*
+      RMAX = Y
+      RETURN
+*
+*     End of DLAMC5
+*
+      END
diff --git a/src/lib/lapack/dlange.f b/src/lib/lapack/dlange.f
new file mode 100644
index 00000000..fec96ac7
--- /dev/null
+++ b/src/lib/lapack/dlange.f
@@ -0,0 +1,144 @@
+      DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANGE  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANGE returns the value
+*
+*     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANGE as described
+*          above.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.  When M = 0,
+*          DLANGE is set to zero.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.  When N = 0,
+*          DLANGE is set to zero.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The m by n matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(M,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( MIN( M, N ).EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         DO 20 J = 1, N
+            DO 10 I = 1, M
+               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         DO 40 J = 1, N
+            SUM = ZERO
+            DO 30 I = 1, M
+               SUM = SUM + ABS( A( I, J ) )
+   30       CONTINUE
+            VALUE = MAX( VALUE, SUM )
+   40    CONTINUE
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         DO 50 I = 1, M
+            WORK( I ) = ZERO
+   50    CONTINUE
+         DO 70 J = 1, N
+            DO 60 I = 1, M
+               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, M
+            VALUE = MAX( VALUE, WORK( I ) )
+   80    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         DO 90 J = 1, N
+            CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANGE = VALUE
+      RETURN
+*
+*     End of DLANGE
+*
+      END
diff --git a/src/lib/lapack/dlanhs.f b/src/lib/lapack/dlanhs.f
new file mode 100644
index 00000000..76b87eeb
--- /dev/null
+++ b/src/lib/lapack/dlanhs.f
@@ -0,0 +1,141 @@
+      DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANHS  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  Hessenberg matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANHS returns the value
+*
+*     DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANHS as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANHS is
+*          set to zero.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The n by n upper Hessenberg matrix A; the part of A below the
+*          first sub-diagonal is not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         DO 20 J = 1, N
+            DO 10 I = 1, MIN( N, J+1 )
+               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         DO 40 J = 1, N
+            SUM = ZERO
+            DO 30 I = 1, MIN( N, J+1 )
+               SUM = SUM + ABS( A( I, J ) )
+   30       CONTINUE
+            VALUE = MAX( VALUE, SUM )
+   40    CONTINUE
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         DO 50 I = 1, N
+            WORK( I ) = ZERO
+   50    CONTINUE
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( N, J+1 )
+               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+   80    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         DO 90 J = 1, N
+            CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANHS = VALUE
+      RETURN
+*
+*     End of DLANHS
+*
+      END
diff --git a/src/lib/lapack/dlansp.f b/src/lib/lapack/dlansp.f
new file mode 100644
index 00000000..ab221006
--- /dev/null
+++ b/src/lib/lapack/dlansp.f
@@ -0,0 +1,196 @@
+      DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM, UPLO
+      INTEGER            N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANSP  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real symmetric matrix A,  supplied in packed form.
+*
+*  Description
+*  ===========
+*
+*  DLANSP returns the value
+*
+*     DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANSP as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is supplied.
+*          = 'U':  Upper triangular part of A is supplied
+*          = 'L':  Lower triangular part of A is supplied
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is
+*          set to zero.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The upper or lower triangle of the symmetric matrix A, packed
+*          columnwise in a linear array.  The j-th column of A is stored
+*          in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, K
+      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            K = 1
+            DO 20 J = 1, N
+               DO 10 I = K, K + J - 1
+                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   10          CONTINUE
+               K = K + J
+   20       CONTINUE
+         ELSE
+            K = 1
+            DO 40 J = 1, N
+               DO 30 I = K, K + N - J
+                  VALUE = MAX( VALUE, ABS( AP( I ) ) )
+   30          CONTINUE
+               K = K + N - J + 1
+   40       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+     $         ( NORM.EQ.'1' ) ) THEN
+*
+*        Find normI(A) ( = norm1(A), since A is symmetric).
+*
+         VALUE = ZERO
+         K = 1
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 60 J = 1, N
+               SUM = ZERO
+               DO 50 I = 1, J - 1
+                  ABSA = ABS( AP( K ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+                  K = K + 1
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( AP( K ) )
+               K = K + 1
+   60       CONTINUE
+            DO 70 I = 1, N
+               VALUE = MAX( VALUE, WORK( I ) )
+   70       CONTINUE
+         ELSE
+            DO 80 I = 1, N
+               WORK( I ) = ZERO
+   80       CONTINUE
+            DO 100 J = 1, N
+               SUM = WORK( J ) + ABS( AP( K ) )
+               K = K + 1
+               DO 90 I = J + 1, N
+                  ABSA = ABS( AP( K ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+                  K = K + 1
+   90          CONTINUE
+               VALUE = MAX( VALUE, SUM )
+  100       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         K = 2
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 2, N
+               CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+               K = K + J
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+               K = K + N - J + 1
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         K = 1
+         DO 130 I = 1, N
+            IF( AP( K ).NE.ZERO ) THEN
+               ABSA = ABS( AP( K ) )
+               IF( SCALE.LT.ABSA ) THEN
+                  SUM = ONE + SUM*( SCALE / ABSA )**2
+                  SCALE = ABSA
+               ELSE
+                  SUM = SUM + ( ABSA / SCALE )**2
+               END IF
+            END IF
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               K = K + I + 1
+            ELSE
+               K = K + N - I + 1
+            END IF
+  130    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANSP = VALUE
+      RETURN
+*
+*     End of DLANSP
+*
+      END
diff --git a/src/lib/lapack/dlanst.f b/src/lib/lapack/dlanst.f
new file mode 100644
index 00000000..2b12091a
--- /dev/null
+++ b/src/lib/lapack/dlanst.f
@@ -0,0 +1,124 @@
+      DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANST  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real symmetric tridiagonal matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANST returns the value
+*
+*     DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANST as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANST is
+*          set to zero.
+*
+*  D       (input) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of A.
+*
+*  E       (input) DOUBLE PRECISION array, dimension (N-1)
+*          The (n-1) sub-diagonal or super-diagonal elements of A.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      DOUBLE PRECISION   ANORM, SCALE, SUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         ANORM = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         ANORM = ABS( D( N ) )
+         DO 10 I = 1, N - 1
+            ANORM = MAX( ANORM, ABS( D( I ) ) )
+            ANORM = MAX( ANORM, ABS( E( I ) ) )
+   10    CONTINUE
+      ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
+     $         LSAME( NORM, 'I' ) ) THEN
+*
+*        Find norm1(A).
+*
+         IF( N.EQ.1 ) THEN
+            ANORM = ABS( D( 1 ) )
+         ELSE
+            ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+     $              ABS( E( N-1 ) )+ABS( D( N ) ) )
+            DO 20 I = 2, N - 1
+               ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
+     $                 ABS( E( I-1 ) ) )
+   20       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         IF( N.GT.1 ) THEN
+            CALL DLASSQ( N-1, E, 1, SCALE, SUM )
+            SUM = 2*SUM
+         END IF
+         CALL DLASSQ( N, D, 1, SCALE, SUM )
+         ANORM = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANST = ANORM
+      RETURN
+*
+*     End of DLANST
+*
+      END
diff --git a/src/lib/lapack/dlansy.f b/src/lib/lapack/dlansy.f
new file mode 100644
index 00000000..b6c727c0
--- /dev/null
+++ b/src/lib/lapack/dlansy.f
@@ -0,0 +1,173 @@
+      DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM, UPLO
+      INTEGER            LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANSY  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  real symmetric matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANSY returns the value
+*
+*     DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANSY as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is to be referenced.
+*          = 'U':  Upper triangular part of A is referenced
+*          = 'L':  Lower triangular part of A is referenced
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, DLANSY is
+*          set to zero.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The symmetric matrix A.  If UPLO = 'U', the leading n by n
+*          upper triangular part of A contains the upper triangular part
+*          of the matrix A, and the strictly lower triangular part of A
+*          is not referenced.  If UPLO = 'L', the leading n by n lower
+*          triangular part of A contains the lower triangular part of
+*          the matrix A, and the strictly upper triangular part of A is
+*          not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = 1, J
+                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10          CONTINUE
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               DO 30 I = J, N
+                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+     $         ( NORM.EQ.'1' ) ) THEN
+*
+*        Find normI(A) ( = norm1(A), since A is symmetric).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 60 J = 1, N
+               SUM = ZERO
+               DO 50 I = 1, J - 1
+                  ABSA = ABS( A( I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( A( J, J ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               VALUE = MAX( VALUE, WORK( I ) )
+   70       CONTINUE
+         ELSE
+            DO 80 I = 1, N
+               WORK( I ) = ZERO
+   80       CONTINUE
+            DO 100 J = 1, N
+               SUM = WORK( J ) + ABS( A( J, J ) )
+               DO 90 I = J + 1, N
+                  ABSA = ABS( A( I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               VALUE = MAX( VALUE, SUM )
+  100       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 2, N
+               CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANSY = VALUE
+      RETURN
+*
+*     End of DLANSY
+*
+      END
diff --git a/src/lib/lapack/dlantr.f b/src/lib/lapack/dlantr.f
new file mode 100644
index 00000000..92debd3d
--- /dev/null
+++ b/src/lib/lapack/dlantr.f
@@ -0,0 +1,276 @@
+      DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
+     $                 WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANTR  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  trapezoidal or triangular matrix A.
+*
+*  Description
+*  ===========
+*
+*  DLANTR returns the value
+*
+*     DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in DLANTR as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the matrix A is upper or lower trapezoidal.
+*          = 'U':  Upper trapezoidal
+*          = 'L':  Lower trapezoidal
+*          Note that A is triangular instead of trapezoidal if M = N.
+*
+*  DIAG    (input) CHARACTER*1
+*          Specifies whether or not the matrix A has unit diagonal.
+*          = 'N':  Non-unit diagonal
+*          = 'U':  Unit diagonal
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0, and if
+*          UPLO = 'U', M <= N.  When M = 0, DLANTR is set to zero.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0, and if
+*          UPLO = 'L', N <= M.  When N = 0, DLANTR is set to zero.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The trapezoidal matrix A (A is triangular if M = N).
+*          If UPLO = 'U', the leading m by n upper trapezoidal part of
+*          the array A contains the upper trapezoidal matrix, and the
+*          strictly lower triangular part of A is not referenced.
+*          If UPLO = 'L', the leading m by n lower trapezoidal part of
+*          the array A contains the lower trapezoidal matrix, and the
+*          strictly upper triangular part of A is not referenced.  Note
+*          that when DIAG = 'U', the diagonal elements of A are not
+*          referenced and are assumed to be one.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(M,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UDIAG
+      INTEGER            I, J
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASSQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( MIN( M, N ).EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         IF( LSAME( DIAG, 'U' ) ) THEN
+            VALUE = ONE
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 20 J = 1, N
+                  DO 10 I = 1, MIN( M, J-1 )
+                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10             CONTINUE
+   20          CONTINUE
+            ELSE
+               DO 40 J = 1, N
+                  DO 30 I = J + 1, M
+                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   30             CONTINUE
+   40          CONTINUE
+            END IF
+         ELSE
+            VALUE = ZERO
+            IF( LSAME( UPLO, 'U' ) ) THEN
+               DO 60 J = 1, N
+                  DO 50 I = 1, MIN( M, J )
+                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   50             CONTINUE
+   60          CONTINUE
+            ELSE
+               DO 80 J = 1, N
+                  DO 70 I = J, M
+                     VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   70             CONTINUE
+   80          CONTINUE
+            END IF
+         END IF
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         UDIAG = LSAME( DIAG, 'U' )
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 1, N
+               IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
+                  SUM = ONE
+                  DO 90 I = 1, J - 1
+                     SUM = SUM + ABS( A( I, J ) )
+   90             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 100 I = 1, MIN( M, J )
+                     SUM = SUM + ABS( A( I, J ) )
+  100             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 140 J = 1, N
+               IF( UDIAG ) THEN
+                  SUM = ONE
+                  DO 120 I = J + 1, M
+                     SUM = SUM + ABS( A( I, J ) )
+  120             CONTINUE
+               ELSE
+                  SUM = ZERO
+                  DO 130 I = J, M
+                     SUM = SUM + ABS( A( I, J ) )
+  130             CONTINUE
+               END IF
+               VALUE = MAX( VALUE, SUM )
+  140       CONTINUE
+         END IF
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 150 I = 1, M
+                  WORK( I ) = ONE
+  150          CONTINUE
+               DO 170 J = 1, N
+                  DO 160 I = 1, MIN( M, J-1 )
+                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+  160             CONTINUE
+  170          CONTINUE
+            ELSE
+               DO 180 I = 1, M
+                  WORK( I ) = ZERO
+  180          CONTINUE
+               DO 200 J = 1, N
+                  DO 190 I = 1, MIN( M, J )
+                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+  190             CONTINUE
+  200          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               DO 210 I = 1, N
+                  WORK( I ) = ONE
+  210          CONTINUE
+               DO 220 I = N + 1, M
+                  WORK( I ) = ZERO
+  220          CONTINUE
+               DO 240 J = 1, N
+                  DO 230 I = J + 1, M
+                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+  230             CONTINUE
+  240          CONTINUE
+            ELSE
+               DO 250 I = 1, M
+                  WORK( I ) = ZERO
+  250          CONTINUE
+               DO 270 J = 1, N
+                  DO 260 I = J, M
+                     WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+  260             CONTINUE
+  270          CONTINUE
+            END IF
+         END IF
+         VALUE = ZERO
+         DO 280 I = 1, M
+            VALUE = MAX( VALUE, WORK( I ) )
+  280    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = MIN( M, N )
+               DO 290 J = 2, N
+                  CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+  290          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 300 J = 1, N
+                  CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
+  300          CONTINUE
+            END IF
+         ELSE
+            IF( LSAME( DIAG, 'U' ) ) THEN
+               SCALE = ONE
+               SUM = MIN( M, N )
+               DO 310 J = 1, N
+                  CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+     $                         SUM )
+  310          CONTINUE
+            ELSE
+               SCALE = ZERO
+               SUM = ONE
+               DO 320 J = 1, N
+                  CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+  320          CONTINUE
+            END IF
+         END IF
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      DLANTR = VALUE
+      RETURN
+*
+*     End of DLANTR
+*
+      END
diff --git a/src/lib/lapack/dlanv2.f b/src/lib/lapack/dlanv2.f
new file mode 100644
index 00000000..cef3f472
--- /dev/null
+++ b/src/lib/lapack/dlanv2.f
@@ -0,0 +1,205 @@
+      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
+*  matrix in standard form:
+*
+*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
+*       [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
+*
+*  where either
+*  1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
+*  2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
+*  conjugate eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  A       (input/output) DOUBLE PRECISION
+*  B       (input/output) DOUBLE PRECISION
+*  C       (input/output) DOUBLE PRECISION
+*  D       (input/output) DOUBLE PRECISION
+*          On entry, the elements of the input matrix.
+*          On exit, they are overwritten by the elements of the
+*          standardised Schur form.
+*
+*  RT1R    (output) DOUBLE PRECISION
+*  RT1I    (output) DOUBLE PRECISION
+*  RT2R    (output) DOUBLE PRECISION
+*  RT2I    (output) DOUBLE PRECISION
+*          The real and imaginary parts of the eigenvalues. If the
+*          eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+*  CS      (output) DOUBLE PRECISION
+*  SN      (output) DOUBLE PRECISION
+*          Parameters of the rotation matrix.
+*
+*  Further Details
+*  ===============
+*
+*  Modified by V. Sima, Research Institute for Informatics, Bucharest,
+*  Romania, to reduce the risk of cancellation errors,
+*  when computing real eigenvalues, and to ensure, if possible, that
+*  abs(RT1R) >= abs(RT2R).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   MULTPL
+      PARAMETER          ( MULTPL = 4.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
+     $                   SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'P' )
+      IF( C.EQ.ZERO ) THEN
+         CS = ONE
+         SN = ZERO
+         GO TO 10
+*
+      ELSE IF( B.EQ.ZERO ) THEN
+*
+*        Swap rows and columns
+*
+         CS = ZERO
+         SN = ONE
+         TEMP = D
+         D = A
+         A = TEMP
+         B = -C
+         C = ZERO
+         GO TO 10
+      ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) )
+     $          THEN
+         CS = ONE
+         SN = ZERO
+         GO TO 10
+      ELSE
+*
+         TEMP = A - D
+         P = HALF*TEMP
+         BCMAX = MAX( ABS( B ), ABS( C ) )
+         BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
+         SCALE = MAX( ABS( P ), BCMAX )
+         Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
+*
+*        If Z is of the order of the machine accuracy, postpone the
+*        decision on the nature of eigenvalues
+*
+         IF( Z.GE.MULTPL*EPS ) THEN
+*
+*           Real eigenvalues. Compute A and D.
+*
+            Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
+            A = D + Z
+            D = D - ( BCMAX / Z )*BCMIS
+*
+*           Compute B and the rotation matrix
+*
+            TAU = DLAPY2( C, Z )
+            CS = Z / TAU
+            SN = C / TAU
+            B = B - C
+            C = ZERO
+         ELSE
+*
+*           Complex eigenvalues, or real (almost) equal eigenvalues.
+*           Make diagonal elements equal.
+*
+            SIGMA = B + C
+            TAU = DLAPY2( SIGMA, TEMP )
+            CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
+            SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
+*
+*           Compute [ AA  BB ] = [ A  B ] [ CS -SN ]
+*                   [ CC  DD ]   [ C  D ] [ SN  CS ]
+*
+            AA = A*CS + B*SN
+            BB = -A*SN + B*CS
+            CC = C*CS + D*SN
+            DD = -C*SN + D*CS
+*
+*           Compute [ A  B ] = [ CS  SN ] [ AA  BB ]
+*                   [ C  D ]   [-SN  CS ] [ CC  DD ]
+*
+            A = AA*CS + CC*SN
+            B = BB*CS + DD*SN
+            C = -AA*SN + CC*CS
+            D = -BB*SN + DD*CS
+*
+            TEMP = HALF*( A+D )
+            A = TEMP
+            D = TEMP
+*
+            IF( C.NE.ZERO ) THEN
+               IF( B.NE.ZERO ) THEN
+                  IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
+*
+*                    Real eigenvalues: reduce to upper triangular form
+*
+                     SAB = SQRT( ABS( B ) )
+                     SAC = SQRT( ABS( C ) )
+                     P = SIGN( SAB*SAC, C )
+                     TAU = ONE / SQRT( ABS( B+C ) )
+                     A = TEMP + P
+                     D = TEMP - P
+                     B = B - C
+                     C = ZERO
+                     CS1 = SAB*TAU
+                     SN1 = SAC*TAU
+                     TEMP = CS*CS1 - SN*SN1
+                     SN = CS*SN1 + SN*CS1
+                     CS = TEMP
+                  END IF
+               ELSE
+                  B = -C
+                  C = ZERO
+                  TEMP = CS
+                  CS = -SN
+                  SN = TEMP
+               END IF
+            END IF
+         END IF
+*
+      END IF
+*
+   10 CONTINUE
+*
+*     Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
+*
+      RT1R = A
+      RT2R = D
+      IF( C.EQ.ZERO ) THEN
+         RT1I = ZERO
+         RT2I = ZERO
+      ELSE
+         RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
+         RT2I = -RT1I
+      END IF
+      RETURN
+*
+*     End of DLANV2
+*
+      END
diff --git a/src/lib/lapack/dlapmt.f b/src/lib/lapack/dlapmt.f
new file mode 100644
index 00000000..325774c0
--- /dev/null
+++ b/src/lib/lapack/dlapmt.f
@@ -0,0 +1,136 @@
+      SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            FORWRD
+      INTEGER            LDX, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            K( * )
+      DOUBLE PRECISION   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAPMT rearranges the columns of the M by N matrix X as specified
+*  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
+*  If FORWRD = .TRUE.,  forward permutation:
+*
+*       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
+*
+*  If FORWRD = .FALSE., backward permutation:
+*
+*       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
+*
+*  Arguments
+*  =========
+*
+*  FORWRD  (input) LOGICAL
+*          = .TRUE., forward permutation
+*          = .FALSE., backward permutation
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix X. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix X. N >= 0.
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
+*          On entry, the M by N matrix X.
+*          On exit, X contains the permuted matrix X.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X, LDX >= MAX(1,M).
+*
+*  K       (input/output) INTEGER array, dimension (N)
+*          On entry, K contains the permutation vector. K is used as
+*          internal workspace, but reset to its original value on
+*          output.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, II, IN, J
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      DO 10 I = 1, N
+         K( I ) = -K( I )
+   10 CONTINUE
+*
+      IF( FORWRD ) THEN
+*
+*        Forward permutation
+*
+         DO 50 I = 1, N
+*
+            IF( K( I ).GT.0 )
+     $         GO TO 40
+*
+            J = I
+            K( J ) = -K( J )
+            IN = K( J )
+*
+   20       CONTINUE
+            IF( K( IN ).GT.0 )
+     $         GO TO 40
+*
+            DO 30 II = 1, M
+               TEMP = X( II, J )
+               X( II, J ) = X( II, IN )
+               X( II, IN ) = TEMP
+   30       CONTINUE
+*
+            K( IN ) = -K( IN )
+            J = IN
+            IN = K( IN )
+            GO TO 20
+*
+   40       CONTINUE
+*
+   50    CONTINUE
+*
+      ELSE
+*
+*        Backward permutation
+*
+         DO 90 I = 1, N
+*
+            IF( K( I ).GT.0 )
+     $         GO TO 80
+*
+            K( I ) = -K( I )
+            J = K( I )
+   60       CONTINUE
+            IF( J.EQ.I )
+     $         GO TO 80
+*
+            DO 70 II = 1, M
+               TEMP = X( II, I )
+               X( II, I ) = X( II, J )
+               X( II, J ) = TEMP
+   70       CONTINUE
+*
+            K( J ) = -K( J )
+            J = K( J )
+            GO TO 60
+*
+   80       CONTINUE
+*
+   90    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLAPMT
+*
+      END
diff --git a/src/lib/lapack/dlapy2.f b/src/lib/lapack/dlapy2.f
new file mode 100644
index 00000000..98ef81b6
--- /dev/null
+++ b/src/lib/lapack/dlapy2.f
@@ -0,0 +1,53 @@
+      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   X, Y
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
+*  overflow.
+*
+*  Arguments
+*  =========
+*
+*  X       (input) DOUBLE PRECISION
+*  Y       (input) DOUBLE PRECISION
+*          X and Y specify the values x and y.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   W, XABS, YABS, Z
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      XABS = ABS( X )
+      YABS = ABS( Y )
+      W = MAX( XABS, YABS )
+      Z = MIN( XABS, YABS )
+      IF( Z.EQ.ZERO ) THEN
+         DLAPY2 = W
+      ELSE
+         DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
+      END IF
+      RETURN
+*
+*     End of DLAPY2
+*
+      END
diff --git a/src/lib/lapack/dlapy3.f b/src/lib/lapack/dlapy3.f
new file mode 100644
index 00000000..2b47bb47
--- /dev/null
+++ b/src/lib/lapack/dlapy3.f
@@ -0,0 +1,56 @@
+      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   X, Y, Z
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
+*  unnecessary overflow.
+*
+*  Arguments
+*  =========
+*
+*  X       (input) DOUBLE PRECISION
+*  Y       (input) DOUBLE PRECISION
+*  Z       (input) DOUBLE PRECISION
+*          X, Y and Z specify the values x, y and z.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   W, XABS, YABS, ZABS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      XABS = ABS( X )
+      YABS = ABS( Y )
+      ZABS = ABS( Z )
+      W = MAX( XABS, YABS, ZABS )
+      IF( W.EQ.ZERO ) THEN
+*     W can be zero for max(0,nan,0)
+*     adding all three entries together will make sure
+*     NaN will not disappear.
+         DLAPY3 =  XABS + YABS + ZABS
+      ELSE
+         DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
+     $            ( ZABS / W )**2 )
+      END IF
+      RETURN
+*
+*     End of DLAPY3
+*
+      END
diff --git a/src/lib/lapack/dlaqge.f b/src/lib/lapack/dlaqge.f
new file mode 100644
index 00000000..9feb927c
--- /dev/null
+++ b/src/lib/lapack/dlaqge.f
@@ -0,0 +1,154 @@
+      SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+     $                   EQUED )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          EQUED
+      INTEGER            LDA, M, N
+      DOUBLE PRECISION   AMAX, COLCND, ROWCND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( * ), R( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQGE equilibrates a general M by N matrix A using the row and
+*  column scaling factors in the vectors R and C.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M by N matrix A.
+*          On exit, the equilibrated matrix.  See EQUED for the form of
+*          the equilibrated matrix.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(M,1).
+*
+*  R       (input) DOUBLE PRECISION array, dimension (M)
+*          The row scale factors for A.
+*
+*  C       (input) DOUBLE PRECISION array, dimension (N)
+*          The column scale factors for A.
+*
+*  ROWCND  (input) DOUBLE PRECISION
+*          Ratio of the smallest R(i) to the largest R(i).
+*
+*  COLCND  (input) DOUBLE PRECISION
+*          Ratio of the smallest C(i) to the largest C(i).
+*
+*  AMAX    (input) DOUBLE PRECISION
+*          Absolute value of largest matrix entry.
+*
+*  EQUED   (output) CHARACTER*1
+*          Specifies the form of equilibration that was done.
+*          = 'N':  No equilibration
+*          = 'R':  Row equilibration, i.e., A has been premultiplied by
+*                  diag(R).
+*          = 'C':  Column equilibration, i.e., A has been postmultiplied
+*                  by diag(C).
+*          = 'B':  Both row and column equilibration, i.e., A has been
+*                  replaced by diag(R) * A * diag(C).
+*
+*  Internal Parameters
+*  ===================
+*
+*  THRESH is a threshold value used to decide if row or column scaling
+*  should be done based on the ratio of the row or column scaling
+*  factors.  If ROWCND < THRESH, row scaling is done, and if
+*  COLCND < THRESH, column scaling is done.
+*
+*  LARGE and SMALL are threshold values used to decide if row scaling
+*  should be done based on the absolute size of the largest matrix
+*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, THRESH
+      PARAMETER          ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   CJ, LARGE, SMALL
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 ) THEN
+         EQUED = 'N'
+         RETURN
+      END IF
+*
+*     Initialize LARGE and SMALL.
+*
+      SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      LARGE = ONE / SMALL
+*
+      IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+     $     THEN
+*
+*        No row scaling
+*
+         IF( COLCND.GE.THRESH ) THEN
+*
+*           No column scaling
+*
+            EQUED = 'N'
+         ELSE
+*
+*           Column scaling
+*
+            DO 20 J = 1, N
+               CJ = C( J )
+               DO 10 I = 1, M
+                  A( I, J ) = CJ*A( I, J )
+   10          CONTINUE
+   20       CONTINUE
+            EQUED = 'C'
+         END IF
+      ELSE IF( COLCND.GE.THRESH ) THEN
+*
+*        Row scaling, no column scaling
+*
+         DO 40 J = 1, N
+            DO 30 I = 1, M
+               A( I, J ) = R( I )*A( I, J )
+   30       CONTINUE
+   40    CONTINUE
+         EQUED = 'R'
+      ELSE
+*
+*        Row and column scaling
+*
+         DO 60 J = 1, N
+            CJ = C( J )
+            DO 50 I = 1, M
+               A( I, J ) = CJ*R( I )*A( I, J )
+   50       CONTINUE
+   60    CONTINUE
+         EQUED = 'B'
+      END IF
+*
+      RETURN
+*
+*     End of DLAQGE
+*
+      END
diff --git a/src/lib/lapack/dlaqp2.f b/src/lib/lapack/dlaqp2.f
new file mode 100644
index 00000000..5ce3b162
--- /dev/null
+++ b/src/lib/lapack/dlaqp2.f
@@ -0,0 +1,175 @@
+      SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
+     $                   WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, M, N, OFFSET
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQP2 computes a QR factorization with column pivoting of
+*  the block A(OFFSET+1:M,1:N).
+*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0.
+*
+*  OFFSET  (input) INTEGER
+*          The number of rows of the matrix A that must be pivoted
+*          but no factorized. OFFSET >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is 
+*          the triangular factor obtained; the elements in block
+*          A(OFFSET+1:M,1:N) below the diagonal, together with the
+*          array TAU, represent the orthogonal matrix Q as a product of
+*          elementary reflectors. Block A(1:OFFSET,1:N) has been
+*          accordingly pivoted, but no factorized.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(i) = 0,
+*          the i-th column of A is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  Partial column norm updating strategy modified by
+*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+*    University of Zagreb, Croatia.
+*    June 2006.
+*  For more details see LAPACK Working Note 176.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
+      DOUBLE PRECISION   AII, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DLARFG, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M-OFFSET, N )
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Compute factorization.
+*
+      DO 20 I = 1, MN
+*
+         OFFPI = OFFSET + I
+*
+*        Determine ith pivot column and swap if necessary.
+*
+         PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
+*
+         IF( PVT.NE.I ) THEN
+            CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+            ITEMP = JPVT( PVT )
+            JPVT( PVT ) = JPVT( I )
+            JPVT( I ) = ITEMP
+            VN1( PVT ) = VN1( I )
+            VN2( PVT ) = VN2( I )
+         END IF
+*
+*        Generate elementary reflector H(i).
+*
+         IF( OFFPI.LT.M ) THEN
+            CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
+         END IF
+*
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i)' to A(offset+i:m,i+1:n) from the left.
+*
+            AII = A( OFFPI, I )
+            A( OFFPI, I ) = ONE
+            CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+     $                  TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
+            A( OFFPI, I ) = AII
+         END IF
+*
+*        Update partial column norms.
+*
+         DO 10 J = I + 1, N
+            IF( VN1( J ).NE.ZERO ) THEN
+*
+*              NOTE: The following 4 lines follow from the analysis in
+*              Lapack Working Note 176.
+*
+               TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
+               TEMP = MAX( TEMP, ZERO )
+               TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+               IF( TEMP2 .LE. TOL3Z ) THEN
+                  IF( OFFPI.LT.M ) THEN
+                     VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+                  ELSE
+                     VN1( J ) = ZERO
+                     VN2( J ) = ZERO
+                  END IF
+               ELSE
+                  VN1( J ) = VN1( J )*SQRT( TEMP )
+               END IF
+            END IF
+   10    CONTINUE
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of DLAQP2
+*
+      END
diff --git a/src/lib/lapack/dlaqps.f b/src/lib/lapack/dlaqps.f
new file mode 100644
index 00000000..94658d27
--- /dev/null
+++ b/src/lib/lapack/dlaqps.f
@@ -0,0 +1,259 @@
+      SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
+     $                   VN2, AUXV, F, LDF )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+     $                   VN1( * ), VN2( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAQPS computes a step of QR factorization with column pivoting
+*  of a real M-by-N matrix A by using Blas-3.  It tries to factorize
+*  NB columns from A starting from the row OFFSET+1, and updates all
+*  of the matrix with Blas-3 xGEMM.
+*
+*  In some cases, due to catastrophic cancellations, it cannot
+*  factorize NB columns.  Hence, the actual number of factorized
+*  columns is returned in KB.
+*
+*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0
+*
+*  OFFSET  (input) INTEGER
+*          The number of rows of A that have been factorized in
+*          previous steps.
+*
+*  NB      (input) INTEGER
+*          The number of columns to factorize.
+*
+*  KB      (output) INTEGER
+*          The number of columns actually factorized.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, block A(OFFSET+1:M,1:KB) is the triangular
+*          factor obtained and block A(1:OFFSET,1:N) has been
+*          accordingly pivoted, but no factorized.
+*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
+*          been updated.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          JPVT(I) = K <==> Column K of the full matrix A has been
+*          permuted into position I in AP.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (KB)
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  AUXV    (input/output) DOUBLE PRECISION array, dimension (NB)
+*          Auxiliar vector.
+*
+*  F       (input/output) DOUBLE PRECISION array, dimension (LDF,NB)
+*          Matrix F' = L*Y'*A.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the array F. LDF >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  Partial column norm updating strategy modified by
+*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+*    University of Zagreb, Croatia.
+*    June 2006.
+*  For more details see LAPACK Working Note 176.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+      DOUBLE PRECISION   AKK, TEMP, TEMP2, TOL3Z
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DGEMV, DLARFG, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, NINT, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      LASTRK = MIN( M, N+OFFSET )
+      LSTICC = 0
+      K = 0
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Beginning of while loop.
+*
+   10 CONTINUE
+      IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
+         K = K + 1
+         RK = OFFSET + K
+*
+*        Determine ith pivot column and swap if necessary
+*
+         PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
+         IF( PVT.NE.K ) THEN
+            CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+            CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
+            ITEMP = JPVT( PVT )
+            JPVT( PVT ) = JPVT( K )
+            JPVT( K ) = ITEMP
+            VN1( PVT ) = VN1( K )
+            VN2( PVT ) = VN2( K )
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'.
+*
+         IF( K.GT.1 ) THEN
+            CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ),
+     $                  LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 )
+         END IF
+*
+*        Generate elementary reflector H(k).
+*
+         IF( RK.LT.M ) THEN
+            CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
+         END IF
+*
+         AKK = A( RK, K )
+         A( RK, K ) = ONE
+*
+*        Compute Kth column of F:
+*
+*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K).
+*
+         IF( K.LT.N ) THEN
+            CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ),
+     $                  A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO,
+     $                  F( K+1, K ), 1 )
+         END IF
+*
+*        Padding F(1:K,K) with zeros.
+*
+         DO 20 J = 1, K
+            F( J, K ) = ZERO
+   20    CONTINUE
+*
+*        Incremental updating of F:
+*        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
+*                    *A(RK:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ),
+     $                  LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
+*
+            CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF,
+     $                  AUXV( 1 ), 1, ONE, F( 1, K ), 1 )
+         END IF
+*
+*        Update the current row of A:
+*        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'.
+*
+         IF( K.LT.N ) THEN
+            CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF,
+     $                  A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA )
+         END IF
+*
+*        Update partial column norms.
+*
+         IF( RK.LT.LASTRK ) THEN
+            DO 30 J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following 4 lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( RK, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+                     VN2( J ) = DBLE( LSTICC )
+                     LSTICC = J
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+   30       CONTINUE
+         END IF
+*
+         A( RK, K ) = AKK
+*
+*        End of while loop.
+*
+         GO TO 10
+      END IF
+      KB = K
+      RK = OFFSET + KB
+*
+*     Apply the block reflector to the rest of the matrix:
+*     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
+*                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
+*
+      IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
+         CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE,
+     $               A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE,
+     $               A( RK+1, KB+1 ), LDA )
+      END IF
+*
+*     Recomputation of difficult columns.
+*
+   40 CONTINUE
+      IF( LSTICC.GT.0 ) THEN
+         ITEMP = NINT( VN2( LSTICC ) )
+         VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 )
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that 
+*        SNRM2 does not fail on vectors with norm below the value of
+*        SQRT(DLAMCH('S')) 
+*
+         VN2( LSTICC ) = VN1( LSTICC )
+         LSTICC = ITEMP
+         GO TO 40
+      END IF
+*
+      RETURN
+*
+*     End of DLAQPS
+*
+      END
diff --git a/src/lib/lapack/dlaqr0.f b/src/lib/lapack/dlaqr0.f
new file mode 100644
index 00000000..479da53d
--- /dev/null
+++ b/src/lib/lapack/dlaqr0.f
@@ -0,0 +1,642 @@
+      SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     DLAQR0 computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+*     Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input orthogonal
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*           previous call to DGEBAL, and then passed to DGEHRD when the
+*           matrix output by DGEBAL is reduced to Hessenberg form.
+*           Otherwise, ILO and IHI should be set to 1 and N,
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+*           the upper quasi-triangular matrix T from the Schur
+*           decomposition (the Schur form); 2-by-2 diagonal blocks
+*           (corresponding to complex conjugate pairs of eigenvalues)
+*           are returned in standard form, with H(i,i) = H(i+1,i+1)
+*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+*           .FALSE., then the contents of H are unspecified on exit.
+*           (The output value of H when INFO.GT.0 is given under the
+*           description of INFO below.)
+*
+*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     WR    (output) DOUBLE PRECISION array, dimension (IHI)
+*     WI    (output) DOUBLE PRECISION array, dimension (IHI)
+*           The real and imaginary parts, respectively, of the computed
+*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+*           and WI(ILO:IHI). If two eigenvalues are computed as a
+*           complex conjugate pair, they are stored in consecutive
+*           elements of WR and WI, say the i-th and (i+1)th, with
+*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+*           the eigenvalues are stored in the same order as on the
+*           diagonal of the Schur form returned in H, with
+*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+*           WI(i+1) = -WI(i).
+*
+*     ILOZ     (input) INTEGER
+*     IHIZ     (input) INTEGER
+*           Specify the rows of Z to which transformations must be
+*           applied if WANTZ is .TRUE..
+*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+*           If WANTZ is .FALSE., then Z is not referenced.
+*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*           (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if WANTZ is .TRUE.
+*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) DOUBLE PRECISION array, dimension LWORK
+*           On exit, if LWORK = -1, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then DLAQR0 does a workspace query.
+*           In this case, DLAQR0 checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .GT. 0:  if INFO = i, DLAQR0 failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*                the remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is an orthogonal matrix.  The final
+*                value of H is upper Hessenberg and quasi-triangular
+*                in rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+*                where U is the orthogonal matrix in (*) (regard-
+*                less of the value of WANTT.)
+*
+*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*                accessed.
+*
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    DLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== Exceptional deflation windows:  try to cure rare
+*     .    slow convergence by increasing the size of the
+*     .    deflation window after KEXNW iterations. =====
+*
+*     ==== Exceptional shifts: try to cure rare slow convergence
+*     .    with ad-hoc exceptional shifts every KEXSH iterations.
+*     .    The constants WILK1 and WILK2 are used to form the
+*     .    exceptional shifts. ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            KEXNW, KEXSH
+      PARAMETER          ( KEXNW = 5, KEXSH = 6 )
+      DOUBLE PRECISION   WILK1, WILK2
+      PARAMETER          ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, CC, CS, DD, SN, SS, SWAP
+      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+     $                   LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+     $                   NSR, NVE, NW, NWMAX, NWR
+      LOGICAL            NWINC, SORTED
+      CHARACTER          JBCMPZ*2
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, MAX, MIN, MOD
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+*
+*     ==== Quick return for N = 0: nothing to do. ====
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+*
+*     ==== Set up job flags for ILAENV. ====
+*
+      IF( WANTT ) THEN
+         JBCMPZ( 1: 1 ) = 'S'
+      ELSE
+         JBCMPZ( 1: 1 ) = 'E'
+      END IF
+      IF( WANTZ ) THEN
+         JBCMPZ( 2: 2 ) = 'V'
+      ELSE
+         JBCMPZ( 2: 2 ) = 'N'
+      END IF
+*
+*     ==== Tiny matrices must use DLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, INFO )
+      ELSE
+*
+*        ==== Use small bulge multi-shift QR with aggressive early
+*        .    deflation on larger-than-tiny matrices. ====
+*
+*        ==== Hope for the best. ====
+*
+         INFO = 0
+*
+*        ==== NWR = recommended deflation window size.  At this
+*        .    point,  N .GT. NTINY = 11, so there is enough
+*        .    subdiagonal workspace for NWR.GE.2 as required.
+*        .    (In fact, there is enough subdiagonal space for
+*        .    NWR.GE.3.) ====
+*
+         NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NWR = MAX( 2, NWR )
+         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+         NW = NWR
+*
+*        ==== NSR = recommended number of simultaneous shifts.
+*        .    At this point N .GT. NTINY = 11, so there is at
+*        .    enough subdiagonal workspace for NSR to be even
+*        .    and greater than or equal to two as required. ====
+*
+         NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+*        ==== Estimate optimal workspace ====
+*
+*        ==== Workspace query call to DLAQR3 ====
+*
+         CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+     $                IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+     $                N, H, LDH, WORK, -1 )
+*
+*        ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = DBLE( LWKOPT )
+            RETURN
+         END IF
+*
+*        ==== DLAHQR/DLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NIBBLE = MAX( 0, NIBBLE )
+*
+*        ==== Accumulate reflections during ttswp?  Use block
+*        .    2-by-2 structure during matrix-matrix multiply? ====
+*
+         KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         KACC22 = MAX( 0, KACC22 )
+         KACC22 = MIN( 2, KACC22 )
+*
+*        ==== NWMAX = the largest possible deflation window for
+*        .    which there is sufficient workspace. ====
+*
+         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+*        ==== NSMAX = the Largest number of simultaneous shifts
+*        .    for which there is sufficient workspace. ====
+*
+         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+         NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+*        ==== NDFL: an iteration count restarted at deflation. ====
+*
+         NDFL = 1
+*
+*        ==== ITMAX = iteration limit ====
+*
+         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+*        ==== Last row and column in the active block ====
+*
+         KBOT = IHI
+*
+*        ==== Main Loop ====
+*
+         DO 80 IT = 1, ITMAX
+*
+*           ==== Done when KBOT falls below ILO ====
+*
+            IF( KBOT.LT.ILO )
+     $         GO TO 90
+*
+*           ==== Locate active block ====
+*
+            DO 10 K = KBOT, ILO + 1, -1
+               IF( H( K, K-1 ).EQ.ZERO )
+     $            GO TO 20
+   10       CONTINUE
+            K = ILO
+   20       CONTINUE
+            KTOP = K
+*
+*           ==== Select deflation window size ====
+*
+            NH = KBOT - KTOP + 1
+            IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+*              ==== Typical deflation window.  If possible and
+*              .    advisable, nibble the entire active block.
+*              .    If not, use size NWR or NWR+1 depending upon
+*              .    which has the smaller corresponding subdiagonal
+*              .    entry (a heuristic). ====
+*
+               NWINC = .TRUE.
+               IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+                  NW = NH
+               ELSE
+                  NW = MIN( NWR, NH, NWMAX )
+                  IF( NW.LT.NWMAX ) THEN
+                     IF( NW.GE.NH-1 ) THEN
+                        NW = NH
+                     ELSE
+                        KWTOP = KBOT - NW + 1
+                        IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+     $                      ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+                     END IF
+                  END IF
+               END IF
+            ELSE
+*
+*              ==== Exceptional deflation window.  If there have
+*              .    been no deflations in KEXNW or more iterations,
+*              .    then vary the deflation window size.   At first,
+*              .    because, larger windows are, in general, more
+*              .    powerful than smaller ones, rapidly increase the
+*              .    window up to the maximum reasonable and possible.
+*              .    Then maybe try a slightly smaller window.  ====
+*
+               IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+                  NW = MIN( NWMAX, NH, 2*NW )
+               ELSE
+                  NWINC = .FALSE.
+                  IF( NW.EQ.NH .AND. NH.GT.2 )
+     $               NW = NH - 1
+               END IF
+            END IF
+*
+*           ==== Aggressive early deflation:
+*           .    split workspace under the subdiagonal into
+*           .      - an nw-by-nw work array V in the lower
+*           .        left-hand-corner,
+*           .      - an NW-by-at-least-NW-but-more-is-better
+*           .        (NW-by-NHO) horizontal work array along
+*           .        the bottom edge,
+*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
+*           .        vertical work array along the left-hand-edge.
+*           .        ====
+*
+            KV = N - NW + 1
+            KT = NW + 1
+            NHO = ( N-NW-1 ) - KT + 1
+            KWV = NW + 2
+            NVE = ( N-NW ) - KWV + 1
+*
+*           ==== Aggressive early deflation ====
+*
+            CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+     $                   NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+     $                   WORK, LWORK )
+*
+*           ==== Adjust KBOT accounting for new deflations. ====
+*
+            KBOT = KBOT - LD
+*
+*           ==== KS points to the shifts. ====
+*
+            KS = KBOT - LS + 1
+*
+*           ==== Skip an expensive QR sweep if there is a (partly
+*           .    heuristic) reason to expect that many eigenvalues
+*           .    will deflate without it.  Here, the QR sweep is
+*           .    skipped if many eigenvalues have just been deflated
+*           .    or if the remaining active block is small.
+*
+            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+*              ==== NS = nominal number of simultaneous shifts.
+*              .    This may be lowered (slightly) if DLAQR3
+*              .    did not provide that many shifts. ====
+*
+               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+               NS = NS - MOD( NS, 2 )
+*
+*              ==== If there have been no deflations
+*              .    in a multiple of KEXSH iterations,
+*              .    then try exceptional shifts.
+*              .    Otherwise use shifts provided by
+*              .    DLAQR3 above or from the eigenvalues
+*              .    of a trailing principal submatrix. ====
+*
+               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+                  KS = KBOT - NS + 1
+                  DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+                     SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+                     AA = WILK1*SS + H( I, I )
+                     BB = SS
+                     CC = WILK2*SS
+                     DD = AA
+                     CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+     $                            WR( I ), WI( I ), CS, SN )
+   30             CONTINUE
+                  IF( KS.EQ.KTOP ) THEN
+                     WR( KS+1 ) = H( KS+1, KS+1 )
+                     WI( KS+1 ) = ZERO
+                     WR( KS ) = WR( KS+1 )
+                     WI( KS ) = WI( KS+1 )
+                  END IF
+               ELSE
+*
+*                 ==== Got NS/2 or fewer shifts? Use DLAQR4 or
+*                 .    DLAHQR on a trailing principal submatrix to
+*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+*                 .    there is enough space below the subdiagonal
+*                 .    to fit an NS-by-NS scratch array.) ====
+*
+                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
+                     KS = KBOT - NS + 1
+                     KT = N - NS + 1
+                     CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     IF( NS.GT.NMIN ) THEN
+                        CALL DLAQR4( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, WR( KS ),
+     $                               WI( KS ), 1, 1, ZDUM, 1, WORK,
+     $                               LWORK, INF )
+                     ELSE
+                        CALL DLAHQR( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, WR( KS ),
+     $                               WI( KS ), 1, 1, ZDUM, 1, INF )
+                     END IF
+                     KS = KS + INF
+*
+*                    ==== In case of a rare QR failure use
+*                    .    eigenvalues of the trailing 2-by-2
+*                    .    principal submatrix.  ====
+*
+                     IF( KS.GE.KBOT ) THEN
+                        AA = H( KBOT-1, KBOT-1 )
+                        CC = H( KBOT, KBOT-1 )
+                        BB = H( KBOT-1, KBOT )
+                        DD = H( KBOT, KBOT )
+                        CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+     $                               WI( KBOT-1 ), WR( KBOT ),
+     $                               WI( KBOT ), CS, SN )
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little)
+*                    .    Bubble sort keeps complex conjugate
+*                    .    pairs together. ====
+*
+                     SORTED = .false.
+                     DO 50 K = KBOT, KS + 1, -1
+                        IF( SORTED )
+     $                     GO TO 60
+                        SORTED = .true.
+                        DO 40 I = KS, K - 1
+                           IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+     $                         ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+                              SORTED = .false.
+*
+                              SWAP = WR( I )
+                              WR( I ) = WR( I+1 )
+                              WR( I+1 ) = SWAP
+*
+                              SWAP = WI( I )
+                              WI( I ) = WI( I+1 )
+                              WI( I+1 ) = SWAP
+                           END IF
+   40                   CONTINUE
+   50                CONTINUE
+   60                CONTINUE
+                  END IF
+*
+*                 ==== Shuffle shifts into pairs of real shifts
+*                 .    and pairs of complex conjugate shifts
+*                 .    assuming complex conjugate shifts are
+*                 .    already adjacent to one another. (Yes,
+*                 .    they are.)  ====
+*
+                  DO 70 I = KBOT, KS + 2, -2
+                     IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+                        SWAP = WR( I )
+                        WR( I ) = WR( I-1 )
+                        WR( I-1 ) = WR( I-2 )
+                        WR( I-2 ) = SWAP
+*
+                        SWAP = WI( I )
+                        WI( I ) = WI( I-1 )
+                        WI( I-1 ) = WI( I-2 )
+                        WI( I-2 ) = SWAP
+                     END IF
+   70             CONTINUE
+               END IF
+*
+*              ==== If there are only two shifts and both are
+*              .    real, then use only one.  ====
+*
+               IF( KBOT-KS+1.EQ.2 ) THEN
+                  IF( WI( KBOT ).EQ.ZERO ) THEN
+                     IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+     $                   ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+                        WR( KBOT-1 ) = WR( KBOT )
+                     ELSE
+                        WR( KBOT ) = WR( KBOT-1 )
+                     END IF
+                  END IF
+               END IF
+*
+*              ==== Use up to NS of the the smallest magnatiude
+*              .    shifts.  If there aren't NS shifts available,
+*              .    then use them all, possibly dropping one to
+*              .    make the number of shifts even. ====
+*
+               NS = MIN( NS, KBOT-KS+1 )
+               NS = NS - MOD( NS, 2 )
+               KS = KBOT - NS + 1
+*
+*              ==== Small-bulge multi-shift QR sweep:
+*              .    split workspace under the subdiagonal into
+*              .    - a KDU-by-KDU work array U in the lower
+*              .      left-hand-corner,
+*              .    - a KDU-by-at-least-KDU-but-more-is-better
+*              .      (KDU-by-NHo) horizontal work array WH along
+*              .      the bottom edge,
+*              .    - and an at-least-KDU-but-more-is-better-by-KDU
+*              .      (NVE-by-KDU) vertical work WV arrow along
+*              .      the left-hand-edge. ====
+*
+               KDU = 3*NS - 3
+               KU = N - KDU + 1
+               KWH = KDU + 1
+               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+               KWV = KDU + 4
+               NVE = N - KDU - KWV + 1
+*
+*              ==== Small-bulge multi-shift QR sweep ====
+*
+               CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+     $                      WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+     $                      LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+     $                      H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+            END IF
+*
+*           ==== Note progress (or the lack of it). ====
+*
+            IF( LD.GT.0 ) THEN
+               NDFL = 1
+            ELSE
+               NDFL = NDFL + 1
+            END IF
+*
+*           ==== End of main loop ====
+   80    CONTINUE
+*
+*        ==== Iteration limit exceeded.  Set INFO to show where
+*        .    the problem occurred and exit. ====
+*
+         INFO = KBOT
+   90    CONTINUE
+      END IF
+*
+*     ==== Return the optimal value of LWORK. ====
+*
+      WORK( 1 ) = DBLE( LWKOPT )
+*
+*     ==== End of DLAQR0 ====
+*
+      END
diff --git a/src/lib/lapack/dlaqr1.f b/src/lib/lapack/dlaqr1.f
new file mode 100644
index 00000000..c80fe668
--- /dev/null
+++ b/src/lib/lapack/dlaqr1.f
@@ -0,0 +1,97 @@
+      SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   SI1, SI2, SR1, SR2
+      INTEGER            LDH, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), V( * )
+*     ..
+*
+*       Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a
+*       scalar multiple of the first column of the product
+*
+*       (*)  K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
+*
+*       scaling to avoid overflows and most underflows. It
+*       is assumed that either
+*
+*               1) sr1 = sr2 and si1 = -si2
+*           or
+*               2) si1 = si2 = 0.
+*
+*       This is useful for starting double implicit shift bulges
+*       in the QR algorithm.
+*
+*
+*       N      (input) integer
+*              Order of the matrix H. N must be either 2 or 3.
+*
+*       H      (input) DOUBLE PRECISION array of dimension (LDH,N)
+*              The 2-by-2 or 3-by-3 matrix H in (*).
+*
+*       LDH    (input) integer
+*              The leading dimension of H as declared in
+*              the calling procedure.  LDH.GE.N
+*
+*       SR1    (input) DOUBLE PRECISION
+*       SI1    The shifts in (*).
+*       SR2
+*       SI2
+*
+*       V      (output) DOUBLE PRECISION array of dimension N
+*              A scalar multiple of the first column of the
+*              matrix K in (*).
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   H21S, H31S, S
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+      IF( N.EQ.2 ) THEN
+         S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
+         IF( S.EQ.ZERO ) THEN
+            V( 1 ) = ZERO
+            V( 2 ) = ZERO
+         ELSE
+            H21S = H( 2, 1 ) / S
+            V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
+     $               ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
+            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
+         END IF
+      ELSE
+         S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
+     $       ABS( H( 3, 1 ) )
+         IF( S.EQ.ZERO ) THEN
+            V( 1 ) = ZERO
+            V( 2 ) = ZERO
+            V( 3 ) = ZERO
+         ELSE
+            H21S = H( 2, 1 ) / S
+            H31S = H( 3, 1 ) / S
+            V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
+     $               SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
+            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
+     $               H( 2, 3 )*H31S
+            V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
+     $               H21S*H( 3, 2 )
+         END IF
+      END IF
+      END
diff --git a/src/lib/lapack/dlaqr2.f b/src/lib/lapack/dlaqr2.f
new file mode 100644
index 00000000..6ddb3309
--- /dev/null
+++ b/src/lib/lapack/dlaqr2.f
@@ -0,0 +1,551 @@
+      SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
+     $                   LDT, NV, WV, LDWV, WORK, LWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+     $                   V( LDV, * ), WORK( * ), WV( LDWV, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This subroutine is identical to DLAQR3 except that it avoids
+*     recursion by calling DLAHQR instead of DLAQR4.
+*
+*
+*     ******************************************************************
+*     Aggressive early deflation:
+*
+*     This subroutine accepts as input an upper Hessenberg matrix
+*     H and performs an orthogonal similarity transformation
+*     designed to detect and deflate fully converged eigenvalues from
+*     a trailing principal submatrix.  On output H has been over-
+*     written by a new Hessenberg matrix that is a perturbation of
+*     an orthogonal similarity transformation of H.  It is to be
+*     hoped that the final version of H has many zero subdiagonal
+*     entries.
+*
+*     ******************************************************************
+*     WANTT   (input) LOGICAL
+*          If .TRUE., then the Hessenberg matrix H is fully updated
+*          so that the quasi-triangular Schur factor may be
+*          computed (in cooperation with the calling subroutine).
+*          If .FALSE., then only enough of H is updated to preserve
+*          the eigenvalues.
+*
+*     WANTZ   (input) LOGICAL
+*          If .TRUE., then the orthogonal matrix Z is updated so
+*          so that the orthogonal Schur factor may be computed
+*          (in cooperation with the calling subroutine).
+*          If .FALSE., then Z is not referenced.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H and (if WANTZ is .TRUE.) the
+*          order of the orthogonal matrix Z.
+*
+*     KTOP    (input) INTEGER
+*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*          KBOT and KTOP together determine an isolated block
+*          along the diagonal of the Hessenberg matrix.
+*
+*     KBOT    (input) INTEGER
+*          It is assumed without a check that either
+*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
+*          determine an isolated block along the diagonal of the
+*          Hessenberg matrix.
+*
+*     NW      (input) INTEGER
+*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*          On input the initial N-by-N section of H stores the
+*          Hessenberg matrix undergoing aggressive early deflation.
+*          On output H has been transformed by an orthogonal
+*          similarity transformation, perturbed, and the returned
+*          to Hessenberg form that (it is to be hoped) has some
+*          zero subdiagonal entries.
+*
+*     LDH     (input) integer
+*          Leading dimension of H just as declared in the calling
+*          subroutine.  N .LE. LDH
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+*          IF WANTZ is .TRUE., then on output, the orthogonal
+*          similarity transformation mentioned above has been
+*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*          If WANTZ is .FALSE., then Z is unreferenced.
+*
+*     LDZ     (input) integer
+*          The leading dimension of Z just as declared in the
+*          calling subroutine.  1 .LE. LDZ.
+*
+*     NS      (output) integer
+*          The number of unconverged (ie approximate) eigenvalues
+*          returned in SR and SI that may be used as shifts by the
+*          calling subroutine.
+*
+*     ND      (output) integer
+*          The number of converged eigenvalues uncovered by this
+*          subroutine.
+*
+*     SR      (output) DOUBLE PRECISION array, dimension KBOT
+*     SI      (output) DOUBLE PRECISION array, dimension KBOT
+*          On output, the real and imaginary parts of approximate
+*          eigenvalues that may be used for shifts are stored in
+*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+*          The real and imaginary parts of converged eigenvalues
+*          are stored in SR(KBOT-ND+1) through SR(KBOT) and
+*          SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+*     V       (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
+*          An NW-by-NW work array.
+*
+*     LDV     (input) integer scalar
+*          The leading dimension of V just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     NH      (input) integer scalar
+*          The number of columns of T.  NH.GE.NW.
+*
+*     T       (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
+*
+*     LDT     (input) integer
+*          The leading dimension of T just as declared in the
+*          calling subroutine.  NW .LE. LDT
+*
+*     NV      (input) integer
+*          The number of rows of work array WV available for
+*          workspace.  NV.GE.NW.
+*
+*     WV      (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) DOUBLE PRECISION array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (input) integer
+*          The dimension of the work array WORK.  LWORK = 2*NW
+*          suffices, but greater efficiency may result from larger
+*          values of LWORK.
+*
+*          If LWORK = -1, then a workspace query is assumed; DLAQR2
+*          only estimates the optimal workspace size for the given
+*          values of N, NW, KTOP and KBOT.  The estimate is returned
+*          in WORK(1).  No error message related to LWORK is issued
+*          by XERBLA.  Neither H nor Z are accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+     $                   SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+     $                   KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
+     $                   LWKOPT
+      LOGICAL            BULGE, SORTED
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
+     $                   DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to DGEHRD ====
+*
+         CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to DORGHR ====
+*
+         CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Optimal workspace ====
+*
+         LWKOPT = JW + MAX( LWK1, LWK2 )
+      END IF
+*
+*     ==== Quick return in case of workspace query. ====
+*
+      IF( LWORK.EQ.-1 ) THEN
+         WORK( 1 ) = DBLE( LWKOPT )
+         RETURN
+      END IF
+*
+*     ==== Nothing to do ...
+*     ... for an empty active block ... ====
+      NS = 0
+      ND = 0
+      IF( KTOP.GT.KBOT )
+     $   RETURN
+*     ... nor for an empty deflation window. ====
+      IF( NW.LT.1 )
+     $   RETURN
+*
+*     ==== Machine constants ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Setup deflation window ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      KWTOP = KBOT - JW + 1
+      IF( KWTOP.EQ.KTOP ) THEN
+         S = ZERO
+      ELSE
+         S = H( KWTOP, KWTOP-1 )
+      END IF
+*
+      IF( KBOT.EQ.KWTOP ) THEN
+*
+*        ==== 1-by-1 deflation window: not much to do ====
+*
+         SR( KWTOP ) = H( KWTOP, KWTOP )
+         SI( KWTOP ) = ZERO
+         NS = 1
+         ND = 0
+         IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+     $        THEN
+            NS = 0
+            ND = 1
+            IF( KWTOP.GT.KTOP )
+     $         H( KWTOP, KWTOP-1 ) = ZERO
+         END IF
+         RETURN
+      END IF
+*
+*     ==== Convert to spike-triangular form.  (In case of a
+*     .    rare QR failure, this routine continues to do
+*     .    aggressive early deflation using that part of
+*     .    the deflation window that converged using INFQR
+*     .    here and there to keep track.) ====
+*
+      CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $             SI( KWTOP ), 1, JW, V, LDV, INFQR )
+*
+*     ==== DTREXC needs a clean margin near the diagonal ====
+*
+      DO 10 J = 1, JW - 3
+         T( J+2, J ) = ZERO
+         T( J+3, J ) = ZERO
+   10 CONTINUE
+      IF( JW.GT.2 )
+     $   T( JW, JW-2 ) = ZERO
+*
+*     ==== Deflation detection loop ====
+*
+      NS = JW
+      ILST = INFQR + 1
+   20 CONTINUE
+      IF( ILST.LE.NS ) THEN
+         IF( NS.EQ.1 ) THEN
+            BULGE = .FALSE.
+         ELSE
+            BULGE = T( NS, NS-1 ).NE.ZERO
+         END IF
+*
+*        ==== Small spike tip test for deflation ====
+*
+         IF( .NOT.BULGE ) THEN
+*
+*           ==== Real eigenvalue ====
+*
+            FOO = ABS( T( NS, NS ) )
+            IF( FOO.EQ.ZERO )
+     $         FOO = ABS( S )
+            IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+*              ==== Deflatable ====
+*
+               NS = NS - 1
+            ELSE
+*
+*              ==== Undeflatable.   Move it up out of the way.
+*              .    (DTREXC can not fail in this case.) ====
+*
+               IFST = NS
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               ILST = ILST + 1
+            END IF
+         ELSE
+*
+*           ==== Complex conjugate pair ====
+*
+            FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+     $            SQRT( ABS( T( NS-1, NS ) ) )
+            IF( FOO.EQ.ZERO )
+     $         FOO = ABS( S )
+            IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+     $          MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+*              ==== Deflatable ====
+*
+               NS = NS - 2
+            ELSE
+*
+*              ==== Undflatable. Move them up out of the way.
+*              .    Fortunately, DTREXC does the right thing with
+*              .    ILST in case of a rare exchange failure. ====
+*
+               IFST = NS
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               ILST = ILST + 2
+            END IF
+         END IF
+*
+*        ==== End deflation detection loop ====
+*
+         GO TO 20
+      END IF
+*
+*        ==== Return to Hessenberg form ====
+*
+      IF( NS.EQ.0 )
+     $   S = ZERO
+*
+      IF( NS.LT.JW ) THEN
+*
+*        ==== sorting diagonal blocks of T improves accuracy for
+*        .    graded matrices.  Bubble sort deals well with
+*        .    exchange failures. ====
+*
+         SORTED = .false.
+         I = NS + 1
+   30    CONTINUE
+         IF( SORTED )
+     $      GO TO 50
+         SORTED = .true.
+*
+         KEND = I - 1
+         I = INFQR + 1
+         IF( I.EQ.NS ) THEN
+            K = I + 1
+         ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+            K = I + 1
+         ELSE
+            K = I + 2
+         END IF
+   40    CONTINUE
+         IF( K.LE.KEND ) THEN
+            IF( K.EQ.I+1 ) THEN
+               EVI = ABS( T( I, I ) )
+            ELSE
+               EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+     $               SQRT( ABS( T( I, I+1 ) ) )
+            END IF
+*
+            IF( K.EQ.KEND ) THEN
+               EVK = ABS( T( K, K ) )
+            ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+               EVK = ABS( T( K, K ) )
+            ELSE
+               EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+     $               SQRT( ABS( T( K, K+1 ) ) )
+            END IF
+*
+            IF( EVI.GE.EVK ) THEN
+               I = K
+            ELSE
+               SORTED = .false.
+               IFST = I
+               ILST = K
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               IF( INFO.EQ.0 ) THEN
+                  I = ILST
+               ELSE
+                  I = K
+               END IF
+            END IF
+            IF( I.EQ.KEND ) THEN
+               K = I + 1
+            ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+               K = I + 1
+            ELSE
+               K = I + 2
+            END IF
+            GO TO 40
+         END IF
+         GO TO 30
+   50    CONTINUE
+      END IF
+*
+*     ==== Restore shift/eigenvalue array from T ====
+*
+      I = JW
+   60 CONTINUE
+      IF( I.GE.INFQR+1 ) THEN
+         IF( I.EQ.INFQR+1 ) THEN
+            SR( KWTOP+I-1 ) = T( I, I )
+            SI( KWTOP+I-1 ) = ZERO
+            I = I - 1
+         ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+            SR( KWTOP+I-1 ) = T( I, I )
+            SI( KWTOP+I-1 ) = ZERO
+            I = I - 1
+         ELSE
+            AA = T( I-1, I-1 )
+            CC = T( I, I-1 )
+            BB = T( I-1, I )
+            DD = T( I, I )
+            CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+     $                   SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+     $                   SI( KWTOP+I-1 ), CS, SN )
+            I = I - 2
+         END IF
+         GO TO 60
+      END IF
+*
+      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+*           ==== Reflect spike back into lower triangle ====
+*
+            CALL DCOPY( NS, V, LDV, WORK, 1 )
+            BETA = WORK( 1 )
+            CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+         END IF
+*
+*        ==== Copy updated reduced window into place ====
+*
+         IF( KWTOP.GT.1 )
+     $      H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+         CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+     $               LDH+1 )
+*
+*        ==== Accumulate orthogonal matrix in order update
+*        .    H and Z, if requested.  (A modified version
+*        .    of  DORGHR that accumulates block Householder
+*        .    transformations into V directly might be
+*        .    marginally more efficient than the following.) ====
+*
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+            CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+         END IF
+*
+*        ==== Update vertical slab in H ====
+*
+         IF( WANTT ) THEN
+            LTOP = 1
+         ELSE
+            LTOP = KTOP
+         END IF
+         DO 70 KROW = LTOP, KWTOP - 1, NV
+            KLN = MIN( NV, KWTOP-KROW )
+            CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+   70    CONTINUE
+*
+*        ==== Update horizontal slab in H ====
+*
+         IF( WANTT ) THEN
+            DO 80 KCOL = KBOT + 1, N, NH
+               KLN = MIN( NH, N-KCOL+1 )
+               CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+     $                      LDH )
+   80       CONTINUE
+         END IF
+*
+*        ==== Update vertical slab in Z ====
+*
+         IF( WANTZ ) THEN
+            DO 90 KROW = ILOZ, IHIZ, NV
+               KLN = MIN( NV, IHIZ-KROW+1 )
+               CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+     $                      LDZ )
+   90       CONTINUE
+         END IF
+      END IF
+*
+*     ==== Return the number of deflations ... ====
+*
+      ND = JW - NS
+*
+*     ==== ... and the number of shifts. (Subtracting
+*     .    INFQR from the spike length takes care
+*     .    of the case of a rare QR failure while
+*     .    calculating eigenvalues of the deflation
+*     .    window.)  ====
+*
+      NS = NS - INFQR
+*
+*      ==== Return optimal workspace. ====
+*
+      WORK( 1 ) = DBLE( LWKOPT )
+*
+*     ==== End of DLAQR2 ====
+*
+      END
diff --git a/src/lib/lapack/dlaqr3.f b/src/lib/lapack/dlaqr3.f
new file mode 100644
index 00000000..877b267a
--- /dev/null
+++ b/src/lib/lapack/dlaqr3.f
@@ -0,0 +1,561 @@
+      SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T,
+     $                   LDT, NV, WV, LDWV, WORK, LWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+     $                   V( LDV, * ), WORK( * ), WV( LDWV, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     ******************************************************************
+*     Aggressive early deflation:
+*
+*     This subroutine accepts as input an upper Hessenberg matrix
+*     H and performs an orthogonal similarity transformation
+*     designed to detect and deflate fully converged eigenvalues from
+*     a trailing principal submatrix.  On output H has been over-
+*     written by a new Hessenberg matrix that is a perturbation of
+*     an orthogonal similarity transformation of H.  It is to be
+*     hoped that the final version of H has many zero subdiagonal
+*     entries.
+*
+*     ******************************************************************
+*     WANTT   (input) LOGICAL
+*          If .TRUE., then the Hessenberg matrix H is fully updated
+*          so that the quasi-triangular Schur factor may be
+*          computed (in cooperation with the calling subroutine).
+*          If .FALSE., then only enough of H is updated to preserve
+*          the eigenvalues.
+*
+*     WANTZ   (input) LOGICAL
+*          If .TRUE., then the orthogonal matrix Z is updated so
+*          so that the orthogonal Schur factor may be computed
+*          (in cooperation with the calling subroutine).
+*          If .FALSE., then Z is not referenced.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H and (if WANTZ is .TRUE.) the
+*          order of the orthogonal matrix Z.
+*
+*     KTOP    (input) INTEGER
+*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*          KBOT and KTOP together determine an isolated block
+*          along the diagonal of the Hessenberg matrix.
+*
+*     KBOT    (input) INTEGER
+*          It is assumed without a check that either
+*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
+*          determine an isolated block along the diagonal of the
+*          Hessenberg matrix.
+*
+*     NW      (input) INTEGER
+*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*          On input the initial N-by-N section of H stores the
+*          Hessenberg matrix undergoing aggressive early deflation.
+*          On output H has been transformed by an orthogonal
+*          similarity transformation, perturbed, and the returned
+*          to Hessenberg form that (it is to be hoped) has some
+*          zero subdiagonal entries.
+*
+*     LDH     (input) integer
+*          Leading dimension of H just as declared in the calling
+*          subroutine.  N .LE. LDH
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+*          IF WANTZ is .TRUE., then on output, the orthogonal
+*          similarity transformation mentioned above has been
+*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*          If WANTZ is .FALSE., then Z is unreferenced.
+*
+*     LDZ     (input) integer
+*          The leading dimension of Z just as declared in the
+*          calling subroutine.  1 .LE. LDZ.
+*
+*     NS      (output) integer
+*          The number of unconverged (ie approximate) eigenvalues
+*          returned in SR and SI that may be used as shifts by the
+*          calling subroutine.
+*
+*     ND      (output) integer
+*          The number of converged eigenvalues uncovered by this
+*          subroutine.
+*
+*     SR      (output) DOUBLE PRECISION array, dimension KBOT
+*     SI      (output) DOUBLE PRECISION array, dimension KBOT
+*          On output, the real and imaginary parts of approximate
+*          eigenvalues that may be used for shifts are stored in
+*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+*          The real and imaginary parts of converged eigenvalues
+*          are stored in SR(KBOT-ND+1) through SR(KBOT) and
+*          SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+*     V       (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
+*          An NW-by-NW work array.
+*
+*     LDV     (input) integer scalar
+*          The leading dimension of V just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     NH      (input) integer scalar
+*          The number of columns of T.  NH.GE.NW.
+*
+*     T       (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
+*
+*     LDT     (input) integer
+*          The leading dimension of T just as declared in the
+*          calling subroutine.  NW .LE. LDT
+*
+*     NV      (input) integer
+*          The number of rows of work array WV available for
+*          workspace.  NV.GE.NW.
+*
+*     WV      (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) DOUBLE PRECISION array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (input) integer
+*          The dimension of the work array WORK.  LWORK = 2*NW
+*          suffices, but greater efficiency may result from larger
+*          values of LWORK.
+*
+*          If LWORK = -1, then a workspace query is assumed; DLAQR3
+*          only estimates the optimal workspace size for the given
+*          values of N, NW, KTOP and KBOT.  The estimate is returned
+*          in WORK(1).  No error message related to LWORK is issued
+*          by XERBLA.  Neither H nor Z are accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ==================================================================
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+     $                   SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+     $                   KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+     $                   LWKOPT, NMIN
+      LOGICAL            BULGE, SORTED
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      INTEGER            ILAENV
+      EXTERNAL           DLAMCH, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
+     $                   DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR,
+     $                   DTREXC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to DGEHRD ====
+*
+         CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to DORGHR ====
+*
+         CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to DLAQR4 ====
+*
+         CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
+     $                V, LDV, WORK, -1, INFQR )
+         LWK3 = INT( WORK( 1 ) )
+*
+*        ==== Optimal workspace ====
+*
+         LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
+      END IF
+*
+*     ==== Quick return in case of workspace query. ====
+*
+      IF( LWORK.EQ.-1 ) THEN
+         WORK( 1 ) = DBLE( LWKOPT )
+         RETURN
+      END IF
+*
+*     ==== Nothing to do ...
+*     ... for an empty active block ... ====
+      NS = 0
+      ND = 0
+      IF( KTOP.GT.KBOT )
+     $   RETURN
+*     ... nor for an empty deflation window. ====
+      IF( NW.LT.1 )
+     $   RETURN
+*
+*     ==== Machine constants ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Setup deflation window ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      KWTOP = KBOT - JW + 1
+      IF( KWTOP.EQ.KTOP ) THEN
+         S = ZERO
+      ELSE
+         S = H( KWTOP, KWTOP-1 )
+      END IF
+*
+      IF( KBOT.EQ.KWTOP ) THEN
+*
+*        ==== 1-by-1 deflation window: not much to do ====
+*
+         SR( KWTOP ) = H( KWTOP, KWTOP )
+         SI( KWTOP ) = ZERO
+         NS = 1
+         ND = 0
+         IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+     $        THEN
+            NS = 0
+            ND = 1
+            IF( KWTOP.GT.KTOP )
+     $         H( KWTOP, KWTOP-1 ) = ZERO
+         END IF
+         RETURN
+      END IF
+*
+*     ==== Convert to spike-triangular form.  (In case of a
+*     .    rare QR failure, this routine continues to do
+*     .    aggressive early deflation using that part of
+*     .    the deflation window that converged using INFQR
+*     .    here and there to keep track.) ====
+*
+      CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK )
+      IF( JW.GT.NMIN ) THEN
+         CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $                SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
+      ELSE
+         CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+     $                SI( KWTOP ), 1, JW, V, LDV, INFQR )
+      END IF
+*
+*     ==== DTREXC needs a clean margin near the diagonal ====
+*
+      DO 10 J = 1, JW - 3
+         T( J+2, J ) = ZERO
+         T( J+3, J ) = ZERO
+   10 CONTINUE
+      IF( JW.GT.2 )
+     $   T( JW, JW-2 ) = ZERO
+*
+*     ==== Deflation detection loop ====
+*
+      NS = JW
+      ILST = INFQR + 1
+   20 CONTINUE
+      IF( ILST.LE.NS ) THEN
+         IF( NS.EQ.1 ) THEN
+            BULGE = .FALSE.
+         ELSE
+            BULGE = T( NS, NS-1 ).NE.ZERO
+         END IF
+*
+*        ==== Small spike tip test for deflation ====
+*
+         IF( .NOT.BULGE ) THEN
+*
+*           ==== Real eigenvalue ====
+*
+            FOO = ABS( T( NS, NS ) )
+            IF( FOO.EQ.ZERO )
+     $         FOO = ABS( S )
+            IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+*              ==== Deflatable ====
+*
+               NS = NS - 1
+            ELSE
+*
+*              ==== Undeflatable.   Move it up out of the way.
+*              .    (DTREXC can not fail in this case.) ====
+*
+               IFST = NS
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               ILST = ILST + 1
+            END IF
+         ELSE
+*
+*           ==== Complex conjugate pair ====
+*
+            FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+     $            SQRT( ABS( T( NS-1, NS ) ) )
+            IF( FOO.EQ.ZERO )
+     $         FOO = ABS( S )
+            IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+     $          MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+*              ==== Deflatable ====
+*
+               NS = NS - 2
+            ELSE
+*
+*              ==== Undflatable. Move them up out of the way.
+*              .    Fortunately, DTREXC does the right thing with
+*              .    ILST in case of a rare exchange failure. ====
+*
+               IFST = NS
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               ILST = ILST + 2
+            END IF
+         END IF
+*
+*        ==== End deflation detection loop ====
+*
+         GO TO 20
+      END IF
+*
+*        ==== Return to Hessenberg form ====
+*
+      IF( NS.EQ.0 )
+     $   S = ZERO
+*
+      IF( NS.LT.JW ) THEN
+*
+*        ==== sorting diagonal blocks of T improves accuracy for
+*        .    graded matrices.  Bubble sort deals well with
+*        .    exchange failures. ====
+*
+         SORTED = .false.
+         I = NS + 1
+   30    CONTINUE
+         IF( SORTED )
+     $      GO TO 50
+         SORTED = .true.
+*
+         KEND = I - 1
+         I = INFQR + 1
+         IF( I.EQ.NS ) THEN
+            K = I + 1
+         ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+            K = I + 1
+         ELSE
+            K = I + 2
+         END IF
+   40    CONTINUE
+         IF( K.LE.KEND ) THEN
+            IF( K.EQ.I+1 ) THEN
+               EVI = ABS( T( I, I ) )
+            ELSE
+               EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+     $               SQRT( ABS( T( I, I+1 ) ) )
+            END IF
+*
+            IF( K.EQ.KEND ) THEN
+               EVK = ABS( T( K, K ) )
+            ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+               EVK = ABS( T( K, K ) )
+            ELSE
+               EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+     $               SQRT( ABS( T( K, K+1 ) ) )
+            END IF
+*
+            IF( EVI.GE.EVK ) THEN
+               I = K
+            ELSE
+               SORTED = .false.
+               IFST = I
+               ILST = K
+               CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+     $                      INFO )
+               IF( INFO.EQ.0 ) THEN
+                  I = ILST
+               ELSE
+                  I = K
+               END IF
+            END IF
+            IF( I.EQ.KEND ) THEN
+               K = I + 1
+            ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+               K = I + 1
+            ELSE
+               K = I + 2
+            END IF
+            GO TO 40
+         END IF
+         GO TO 30
+   50    CONTINUE
+      END IF
+*
+*     ==== Restore shift/eigenvalue array from T ====
+*
+      I = JW
+   60 CONTINUE
+      IF( I.GE.INFQR+1 ) THEN
+         IF( I.EQ.INFQR+1 ) THEN
+            SR( KWTOP+I-1 ) = T( I, I )
+            SI( KWTOP+I-1 ) = ZERO
+            I = I - 1
+         ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+            SR( KWTOP+I-1 ) = T( I, I )
+            SI( KWTOP+I-1 ) = ZERO
+            I = I - 1
+         ELSE
+            AA = T( I-1, I-1 )
+            CC = T( I, I-1 )
+            BB = T( I-1, I )
+            DD = T( I, I )
+            CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+     $                   SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+     $                   SI( KWTOP+I-1 ), CS, SN )
+            I = I - 2
+         END IF
+         GO TO 60
+      END IF
+*
+      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+*           ==== Reflect spike back into lower triangle ====
+*
+            CALL DCOPY( NS, V, LDV, WORK, 1 )
+            BETA = WORK( 1 )
+            CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+         END IF
+*
+*        ==== Copy updated reduced window into place ====
+*
+         IF( KWTOP.GT.1 )
+     $      H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+         CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+     $               LDH+1 )
+*
+*        ==== Accumulate orthogonal matrix in order update
+*        .    H and Z, if requested.  (A modified version
+*        .    of  DORGHR that accumulates block Householder
+*        .    transformations into V directly might be
+*        .    marginally more efficient than the following.) ====
+*
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+            CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+         END IF
+*
+*        ==== Update vertical slab in H ====
+*
+         IF( WANTT ) THEN
+            LTOP = 1
+         ELSE
+            LTOP = KTOP
+         END IF
+         DO 70 KROW = LTOP, KWTOP - 1, NV
+            KLN = MIN( NV, KWTOP-KROW )
+            CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+   70    CONTINUE
+*
+*        ==== Update horizontal slab in H ====
+*
+         IF( WANTT ) THEN
+            DO 80 KCOL = KBOT + 1, N, NH
+               KLN = MIN( NH, N-KCOL+1 )
+               CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+     $                      LDH )
+   80       CONTINUE
+         END IF
+*
+*        ==== Update vertical slab in Z ====
+*
+         IF( WANTZ ) THEN
+            DO 90 KROW = ILOZ, IHIZ, NV
+               KLN = MIN( NV, IHIZ-KROW+1 )
+               CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+     $                      LDZ )
+   90       CONTINUE
+         END IF
+      END IF
+*
+*     ==== Return the number of deflations ... ====
+*
+      ND = JW - NS
+*
+*     ==== ... and the number of shifts. (Subtracting
+*     .    INFQR from the spike length takes care
+*     .    of the case of a rare QR failure while
+*     .    calculating eigenvalues of the deflation
+*     .    window.)  ====
+*
+      NS = NS - INFQR
+*
+*      ==== Return optimal workspace. ====
+*
+      WORK( 1 ) = DBLE( LWKOPT )
+*
+*     ==== End of DLAQR3 ====
+*
+      END
diff --git a/src/lib/lapack/dlaqr4.f b/src/lib/lapack/dlaqr4.f
new file mode 100644
index 00000000..8692e7f9
--- /dev/null
+++ b/src/lib/lapack/dlaqr4.f
@@ -0,0 +1,640 @@
+      SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This subroutine implements one level of recursion for DLAQR0.
+*     It is a complete implementation of the small bulge multi-shift
+*     QR algorithm.  It may be called by DLAQR0 and, for large enough
+*     deflation window size, it may be called by DLAQR3.  This
+*     subroutine is identical to DLAQR0 except that it calls DLAQR2
+*     instead of DLAQR3.
+*
+*     Purpose
+*     =======
+*
+*     DLAQR4 computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+*     Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input orthogonal
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*           previous call to DGEBAL, and then passed to DGEHRD when the
+*           matrix output by DGEBAL is reduced to Hessenberg form.
+*           Otherwise, ILO and IHI should be set to 1 and N,
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+*           the upper quasi-triangular matrix T from the Schur
+*           decomposition (the Schur form); 2-by-2 diagonal blocks
+*           (corresponding to complex conjugate pairs of eigenvalues)
+*           are returned in standard form, with H(i,i) = H(i+1,i+1)
+*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+*           .FALSE., then the contents of H are unspecified on exit.
+*           (The output value of H when INFO.GT.0 is given under the
+*           description of INFO below.)
+*
+*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     WR    (output) DOUBLE PRECISION array, dimension (IHI)
+*     WI    (output) DOUBLE PRECISION array, dimension (IHI)
+*           The real and imaginary parts, respectively, of the computed
+*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+*           and WI(ILO:IHI). If two eigenvalues are computed as a
+*           complex conjugate pair, they are stored in consecutive
+*           elements of WR and WI, say the i-th and (i+1)th, with
+*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+*           the eigenvalues are stored in the same order as on the
+*           diagonal of the Schur form returned in H, with
+*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+*           WI(i+1) = -WI(i).
+*
+*     ILOZ     (input) INTEGER
+*     IHIZ     (input) INTEGER
+*           Specify the rows of Z to which transformations must be
+*           applied if WANTZ is .TRUE..
+*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+*           If WANTZ is .FALSE., then Z is not referenced.
+*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*           (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if WANTZ is .TRUE.
+*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) DOUBLE PRECISION array, dimension LWORK
+*           On exit, if LWORK = -1, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then DLAQR4 does a workspace query.
+*           In this case, DLAQR4 checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .GT. 0:  if INFO = i, DLAQR4 failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*                the remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is an orthogonal matrix.  The final
+*                value of H is upper Hessenberg and quasi-triangular
+*                in rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+*                where U is the orthogonal matrix in (*) (regard-
+*                less of the value of WANTT.)
+*
+*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*                accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    DLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== Exceptional deflation windows:  try to cure rare
+*     .    slow convergence by increasing the size of the
+*     .    deflation window after KEXNW iterations. =====
+*
+*     ==== Exceptional shifts: try to cure rare slow convergence
+*     .    with ad-hoc exceptional shifts every KEXSH iterations.
+*     .    The constants WILK1 and WILK2 are used to form the
+*     .    exceptional shifts. ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            KEXNW, KEXSH
+      PARAMETER          ( KEXNW = 5, KEXSH = 6 )
+      DOUBLE PRECISION   WILK1, WILK2
+      PARAMETER          ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AA, BB, CC, CS, DD, SN, SS, SWAP
+      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+     $                   LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+     $                   NSR, NVE, NW, NWMAX, NWR
+      LOGICAL            NWINC, SORTED
+      CHARACTER          JBCMPZ*2
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, INT, MAX, MIN, MOD
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+*
+*     ==== Quick return for N = 0: nothing to do. ====
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+*
+*     ==== Set up job flags for ILAENV. ====
+*
+      IF( WANTT ) THEN
+         JBCMPZ( 1: 1 ) = 'S'
+      ELSE
+         JBCMPZ( 1: 1 ) = 'E'
+      END IF
+      IF( WANTZ ) THEN
+         JBCMPZ( 2: 2 ) = 'V'
+      ELSE
+         JBCMPZ( 2: 2 ) = 'N'
+      END IF
+*
+*     ==== Tiny matrices must use DLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+     $                   ILOZ, IHIZ, Z, LDZ, INFO )
+      ELSE
+*
+*        ==== Use small bulge multi-shift QR with aggressive early
+*        .    deflation on larger-than-tiny matrices. ====
+*
+*        ==== Hope for the best. ====
+*
+         INFO = 0
+*
+*        ==== NWR = recommended deflation window size.  At this
+*        .    point,  N .GT. NTINY = 11, so there is enough
+*        .    subdiagonal workspace for NWR.GE.2 as required.
+*        .    (In fact, there is enough subdiagonal space for
+*        .    NWR.GE.3.) ====
+*
+         NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NWR = MAX( 2, NWR )
+         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+         NW = NWR
+*
+*        ==== NSR = recommended number of simultaneous shifts.
+*        .    At this point N .GT. NTINY = 11, so there is at
+*        .    enough subdiagonal workspace for NSR to be even
+*        .    and greater than or equal to two as required. ====
+*
+         NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+*        ==== Estimate optimal workspace ====
+*
+*        ==== Workspace query call to DLAQR2 ====
+*
+         CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+     $                IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+     $                N, H, LDH, WORK, -1 )
+*
+*        ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = DBLE( LWKOPT )
+            RETURN
+         END IF
+*
+*        ==== DLAHQR/DLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NIBBLE = MAX( 0, NIBBLE )
+*
+*        ==== Accumulate reflections during ttswp?  Use block
+*        .    2-by-2 structure during matrix-matrix multiply? ====
+*
+         KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         KACC22 = MAX( 0, KACC22 )
+         KACC22 = MIN( 2, KACC22 )
+*
+*        ==== NWMAX = the largest possible deflation window for
+*        .    which there is sufficient workspace. ====
+*
+         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+*        ==== NSMAX = the Largest number of simultaneous shifts
+*        .    for which there is sufficient workspace. ====
+*
+         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+         NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+*        ==== NDFL: an iteration count restarted at deflation. ====
+*
+         NDFL = 1
+*
+*        ==== ITMAX = iteration limit ====
+*
+         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+*        ==== Last row and column in the active block ====
+*
+         KBOT = IHI
+*
+*        ==== Main Loop ====
+*
+         DO 80 IT = 1, ITMAX
+*
+*           ==== Done when KBOT falls below ILO ====
+*
+            IF( KBOT.LT.ILO )
+     $         GO TO 90
+*
+*           ==== Locate active block ====
+*
+            DO 10 K = KBOT, ILO + 1, -1
+               IF( H( K, K-1 ).EQ.ZERO )
+     $            GO TO 20
+   10       CONTINUE
+            K = ILO
+   20       CONTINUE
+            KTOP = K
+*
+*           ==== Select deflation window size ====
+*
+            NH = KBOT - KTOP + 1
+            IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+*              ==== Typical deflation window.  If possible and
+*              .    advisable, nibble the entire active block.
+*              .    If not, use size NWR or NWR+1 depending upon
+*              .    which has the smaller corresponding subdiagonal
+*              .    entry (a heuristic). ====
+*
+               NWINC = .TRUE.
+               IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+                  NW = NH
+               ELSE
+                  NW = MIN( NWR, NH, NWMAX )
+                  IF( NW.LT.NWMAX ) THEN
+                     IF( NW.GE.NH-1 ) THEN
+                        NW = NH
+                     ELSE
+                        KWTOP = KBOT - NW + 1
+                        IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+     $                      ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+                     END IF
+                  END IF
+               END IF
+            ELSE
+*
+*              ==== Exceptional deflation window.  If there have
+*              .    been no deflations in KEXNW or more iterations,
+*              .    then vary the deflation window size.   At first,
+*              .    because, larger windows are, in general, more
+*              .    powerful than smaller ones, rapidly increase the
+*              .    window up to the maximum reasonable and possible.
+*              .    Then maybe try a slightly smaller window.  ====
+*
+               IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+                  NW = MIN( NWMAX, NH, 2*NW )
+               ELSE
+                  NWINC = .FALSE.
+                  IF( NW.EQ.NH .AND. NH.GT.2 )
+     $               NW = NH - 1
+               END IF
+            END IF
+*
+*           ==== Aggressive early deflation:
+*           .    split workspace under the subdiagonal into
+*           .      - an nw-by-nw work array V in the lower
+*           .        left-hand-corner,
+*           .      - an NW-by-at-least-NW-but-more-is-better
+*           .        (NW-by-NHO) horizontal work array along
+*           .        the bottom edge,
+*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
+*           .        vertical work array along the left-hand-edge.
+*           .        ====
+*
+            KV = N - NW + 1
+            KT = NW + 1
+            NHO = ( N-NW-1 ) - KT + 1
+            KWV = NW + 2
+            NVE = ( N-NW ) - KWV + 1
+*
+*           ==== Aggressive early deflation ====
+*
+            CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+     $                   NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+     $                   WORK, LWORK )
+*
+*           ==== Adjust KBOT accounting for new deflations. ====
+*
+            KBOT = KBOT - LD
+*
+*           ==== KS points to the shifts. ====
+*
+            KS = KBOT - LS + 1
+*
+*           ==== Skip an expensive QR sweep if there is a (partly
+*           .    heuristic) reason to expect that many eigenvalues
+*           .    will deflate without it.  Here, the QR sweep is
+*           .    skipped if many eigenvalues have just been deflated
+*           .    or if the remaining active block is small.
+*
+            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+*              ==== NS = nominal number of simultaneous shifts.
+*              .    This may be lowered (slightly) if DLAQR2
+*              .    did not provide that many shifts. ====
+*
+               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+               NS = NS - MOD( NS, 2 )
+*
+*              ==== If there have been no deflations
+*              .    in a multiple of KEXSH iterations,
+*              .    then try exceptional shifts.
+*              .    Otherwise use shifts provided by
+*              .    DLAQR2 above or from the eigenvalues
+*              .    of a trailing principal submatrix. ====
+*
+               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+                  KS = KBOT - NS + 1
+                  DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+                     SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+                     AA = WILK1*SS + H( I, I )
+                     BB = SS
+                     CC = WILK2*SS
+                     DD = AA
+                     CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+     $                            WR( I ), WI( I ), CS, SN )
+   30             CONTINUE
+                  IF( KS.EQ.KTOP ) THEN
+                     WR( KS+1 ) = H( KS+1, KS+1 )
+                     WI( KS+1 ) = ZERO
+                     WR( KS ) = WR( KS+1 )
+                     WI( KS ) = WI( KS+1 )
+                  END IF
+               ELSE
+*
+*                 ==== Got NS/2 or fewer shifts? Use DLAHQR
+*                 .    on a trailing principal submatrix to
+*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+*                 .    there is enough space below the subdiagonal
+*                 .    to fit an NS-by-NS scratch array.) ====
+*
+                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
+                     KS = KBOT - NS + 1
+                     KT = N - NS + 1
+                     CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     CALL DLAHQR( .false., .false., NS, 1, NS,
+     $                            H( KT, 1 ), LDH, WR( KS ), WI( KS ),
+     $                            1, 1, ZDUM, 1, INF )
+                     KS = KS + INF
+*
+*                    ==== In case of a rare QR failure use
+*                    .    eigenvalues of the trailing 2-by-2
+*                    .    principal submatrix.  ====
+*
+                     IF( KS.GE.KBOT ) THEN
+                        AA = H( KBOT-1, KBOT-1 )
+                        CC = H( KBOT, KBOT-1 )
+                        BB = H( KBOT-1, KBOT )
+                        DD = H( KBOT, KBOT )
+                        CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+     $                               WI( KBOT-1 ), WR( KBOT ),
+     $                               WI( KBOT ), CS, SN )
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little)
+*                    .    Bubble sort keeps complex conjugate
+*                    .    pairs together. ====
+*
+                     SORTED = .false.
+                     DO 50 K = KBOT, KS + 1, -1
+                        IF( SORTED )
+     $                     GO TO 60
+                        SORTED = .true.
+                        DO 40 I = KS, K - 1
+                           IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+     $                         ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+                              SORTED = .false.
+*
+                              SWAP = WR( I )
+                              WR( I ) = WR( I+1 )
+                              WR( I+1 ) = SWAP
+*
+                              SWAP = WI( I )
+                              WI( I ) = WI( I+1 )
+                              WI( I+1 ) = SWAP
+                           END IF
+   40                   CONTINUE
+   50                CONTINUE
+   60                CONTINUE
+                  END IF
+*
+*                 ==== Shuffle shifts into pairs of real shifts
+*                 .    and pairs of complex conjugate shifts
+*                 .    assuming complex conjugate shifts are
+*                 .    already adjacent to one another. (Yes,
+*                 .    they are.)  ====
+*
+                  DO 70 I = KBOT, KS + 2, -2
+                     IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+                        SWAP = WR( I )
+                        WR( I ) = WR( I-1 )
+                        WR( I-1 ) = WR( I-2 )
+                        WR( I-2 ) = SWAP
+*
+                        SWAP = WI( I )
+                        WI( I ) = WI( I-1 )
+                        WI( I-1 ) = WI( I-2 )
+                        WI( I-2 ) = SWAP
+                     END IF
+   70             CONTINUE
+               END IF
+*
+*              ==== If there are only two shifts and both are
+*              .    real, then use only one.  ====
+*
+               IF( KBOT-KS+1.EQ.2 ) THEN
+                  IF( WI( KBOT ).EQ.ZERO ) THEN
+                     IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+     $                   ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+                        WR( KBOT-1 ) = WR( KBOT )
+                     ELSE
+                        WR( KBOT ) = WR( KBOT-1 )
+                     END IF
+                  END IF
+               END IF
+*
+*              ==== Use up to NS of the the smallest magnatiude
+*              .    shifts.  If there aren't NS shifts available,
+*              .    then use them all, possibly dropping one to
+*              .    make the number of shifts even. ====
+*
+               NS = MIN( NS, KBOT-KS+1 )
+               NS = NS - MOD( NS, 2 )
+               KS = KBOT - NS + 1
+*
+*              ==== Small-bulge multi-shift QR sweep:
+*              .    split workspace under the subdiagonal into
+*              .    - a KDU-by-KDU work array U in the lower
+*              .      left-hand-corner,
+*              .    - a KDU-by-at-least-KDU-but-more-is-better
+*              .      (KDU-by-NHo) horizontal work array WH along
+*              .      the bottom edge,
+*              .    - and an at-least-KDU-but-more-is-better-by-KDU
+*              .      (NVE-by-KDU) vertical work WV arrow along
+*              .      the left-hand-edge. ====
+*
+               KDU = 3*NS - 3
+               KU = N - KDU + 1
+               KWH = KDU + 1
+               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+               KWV = KDU + 4
+               NVE = N - KDU - KWV + 1
+*
+*              ==== Small-bulge multi-shift QR sweep ====
+*
+               CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+     $                      WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+     $                      LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+     $                      H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+            END IF
+*
+*           ==== Note progress (or the lack of it). ====
+*
+            IF( LD.GT.0 ) THEN
+               NDFL = 1
+            ELSE
+               NDFL = NDFL + 1
+            END IF
+*
+*           ==== End of main loop ====
+   80    CONTINUE
+*
+*        ==== Iteration limit exceeded.  Set INFO to show where
+*        .    the problem occurred and exit. ====
+*
+         INFO = KBOT
+   90    CONTINUE
+      END IF
+*
+*     ==== Return the optimal value of LWORK. ====
+*
+      WORK( 1 ) = DBLE( LWKOPT )
+*
+*     ==== End of DLAQR4 ====
+*
+      END
diff --git a/src/lib/lapack/dlaqr5.f b/src/lib/lapack/dlaqr5.f
new file mode 100644
index 00000000..17857572
--- /dev/null
+++ b/src/lib/lapack/dlaqr5.f
@@ -0,0 +1,812 @@
+      SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
+     $                   SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U,
+     $                   LDU, NV, WV, LDWV, NH, WH, LDWH )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+     $                   LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+     $                   V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*     This auxiliary subroutine called by DLAQR0 performs a
+*     single small-bulge multi-shift QR sweep.
+*
+*      WANTT  (input) logical scalar
+*             WANTT = .true. if the quasi-triangular Schur factor
+*             is being computed.  WANTT is set to .false. otherwise.
+*
+*      WANTZ  (input) logical scalar
+*             WANTZ = .true. if the orthogonal Schur factor is being
+*             computed.  WANTZ is set to .false. otherwise.
+*
+*      KACC22 (input) integer with value 0, 1, or 2.
+*             Specifies the computation mode of far-from-diagonal
+*             orthogonal updates.
+*        = 0: DLAQR5 does not accumulate reflections and does not
+*             use matrix-matrix multiply to update far-from-diagonal
+*             matrix entries.
+*        = 1: DLAQR5 accumulates reflections and uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries.
+*        = 2: DLAQR5 accumulates reflections, uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries,
+*             and takes advantage of 2-by-2 block structure during
+*             matrix multiplies.
+*
+*      N      (input) integer scalar
+*             N is the order of the Hessenberg matrix H upon which this
+*             subroutine operates.
+*
+*      KTOP   (input) integer scalar
+*      KBOT   (input) integer scalar
+*             These are the first and last rows and columns of an
+*             isolated diagonal block upon which the QR sweep is to be
+*             applied. It is assumed without a check that
+*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
+*             and
+*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
+*
+*      NSHFTS (input) integer scalar
+*             NSHFTS gives the number of simultaneous shifts.  NSHFTS
+*             must be positive and even.
+*
+*      SR     (input) DOUBLE PRECISION array of size (NSHFTS)
+*      SI     (input) DOUBLE PRECISION array of size (NSHFTS)
+*             SR contains the real parts and SI contains the imaginary
+*             parts of the NSHFTS shifts of origin that define the
+*             multi-shift QR sweep.
+*
+*      H      (input/output) DOUBLE PRECISION array of size (LDH,N)
+*             On input H contains a Hessenberg matrix.  On output a
+*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+*             to the isolated diagonal block in rows and columns KTOP
+*             through KBOT.
+*
+*      LDH    (input) integer scalar
+*             LDH is the leading dimension of H just as declared in the
+*             calling procedure.  LDH.GE.MAX(1,N).
+*
+*      ILOZ   (input) INTEGER
+*      IHIZ   (input) INTEGER
+*             Specify the rows of Z to which transformations must be
+*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+*      Z      (input/output) DOUBLE PRECISION array of size (LDZ,IHI)
+*             If WANTZ = .TRUE., then the QR Sweep orthogonal
+*             similarity transformation is accumulated into
+*             Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*             If WANTZ = .FALSE., then Z is unreferenced.
+*
+*      LDZ    (input) integer scalar
+*             LDA is the leading dimension of Z just as declared in
+*             the calling procedure. LDZ.GE.N.
+*
+*      V      (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)
+*
+*      LDV    (input) integer scalar
+*             LDV is the leading dimension of V as declared in the
+*             calling procedure.  LDV.GE.3.
+*
+*      U      (workspace) DOUBLE PRECISION array of size
+*             (LDU,3*NSHFTS-3)
+*
+*      LDU    (input) integer scalar
+*             LDU is the leading dimension of U just as declared in the
+*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.
+*
+*      NH     (input) integer scalar
+*             NH is the number of columns in array WH available for
+*             workspace. NH.GE.1.
+*
+*      WH     (workspace) DOUBLE PRECISION array of size (LDWH,NH)
+*
+*      LDWH   (input) integer scalar
+*             Leading dimension of WH just as declared in the
+*             calling procedure.  LDWH.GE.3*NSHFTS-3.
+*
+*      NV     (input) integer scalar
+*             NV is the number of rows in WV agailable for workspace.
+*             NV.GE.1.
+*
+*      WV     (workspace) DOUBLE PRECISION array of size
+*             (LDWV,3*NSHFTS-3)
+*
+*      LDWV   (input) integer scalar
+*             LDWV is the leading dimension of WV as declared in the
+*             in the calling subroutine.  LDWV.GE.NV.
+*
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ============================================================
+*     Reference:
+*
+*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*     Algorithm Part I: Maintaining Well Focused Shifts, and
+*     Level 3 Performance, SIAM Journal of Matrix Analysis,
+*     volume 23, pages 929--947, 2002.
+*
+*     ============================================================
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0d0, ONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+     $                   SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+     $                   ULP
+      INTEGER            I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+     $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+     $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+     $                   NS, NU
+      LOGICAL            ACCUM, BLK22, BMP22
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+*
+      INTRINSIC          ABS, DBLE, MAX, MIN, MOD
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   VT( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET,
+     $                   DTRMM
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== If there are no shifts, then there is nothing to do. ====
+*
+      IF( NSHFTS.LT.2 )
+     $   RETURN
+*
+*     ==== If the active block is empty or 1-by-1, then there
+*     .    is nothing to do. ====
+*
+      IF( KTOP.GE.KBOT )
+     $   RETURN
+*
+*     ==== Shuffle shifts into pairs of real shifts and pairs
+*     .    of complex conjugate shifts assuming complex
+*     .    conjugate shifts are already adjacent to one
+*     .    another. ====
+*
+      DO 10 I = 1, NSHFTS - 2, 2
+         IF( SI( I ).NE.-SI( I+1 ) ) THEN
+*
+            SWAP = SR( I )
+            SR( I ) = SR( I+1 )
+            SR( I+1 ) = SR( I+2 )
+            SR( I+2 ) = SWAP
+*
+            SWAP = SI( I )
+            SI( I ) = SI( I+1 )
+            SI( I+1 ) = SI( I+2 )
+            SI( I+2 ) = SWAP
+         END IF
+   10 CONTINUE
+*
+*     ==== NSHFTS is supposed to be even, but if is odd,
+*     .    then simply reduce it by one.  The shuffle above
+*     .    ensures that the dropped shift is real and that
+*     .    the remaining shifts are paired. ====
+*
+      NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+*     ==== Machine constants for deflation ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Use accumulated reflections to update far-from-diagonal
+*     .    entries ? ====
+*
+      ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+*
+*     ==== If so, exploit the 2-by-2 block structure? ====
+*
+      BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+*     ==== clear trash ====
+*
+      IF( KTOP+2.LE.KBOT )
+     $   H( KTOP+2, KTOP ) = ZERO
+*
+*     ==== NBMPS = number of 2-shift bulges in the chain ====
+*
+      NBMPS = NS / 2
+*
+*     ==== KDU = width of slab ====
+*
+      KDU = 6*NBMPS - 3
+*
+*     ==== Create and chase chains of NBMPS bulges ====
+*
+      DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
+         NDCOL = INCOL + KDU
+         IF( ACCUM )
+     $      CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
+*
+*        ==== Near-the-diagonal bulge chase.  The following loop
+*        .    performs the near-the-diagonal part of a small bulge
+*        .    multi-shift QR sweep.  Each 6*NBMPS-2 column diagonal
+*        .    chunk extends from column INCOL to column NDCOL
+*        .    (including both column INCOL and column NDCOL). The
+*        .    following loop chases a 3*NBMPS column long chain of
+*        .    NBMPS bulges 3*NBMPS-2 columns to the right.  (INCOL
+*        .    may be less than KTOP and and NDCOL may be greater than
+*        .    KBOT indicating phantom columns from which to chase
+*        .    bulges before they are actually introduced or to which
+*        .    to chase bulges beyond column KBOT.)  ====
+*
+         DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
+*
+*           ==== Bulges number MTOP to MBOT are active double implicit
+*           .    shift bulges.  There may or may not also be small
+*           .    2-by-2 bulge, if there is room.  The inactive bulges
+*           .    (if any) must wait until the active bulges have moved
+*           .    down the diagonal to make room.  The phantom matrix
+*           .    paradigm described above helps keep track.  ====
+*
+            MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
+            MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
+            M22 = MBOT + 1
+            BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
+     $              ( KBOT-2 )
+*
+*           ==== Generate reflections to chase the chain right
+*           .    one column.  (The minimum value of K is KTOP-1.) ====
+*
+            DO 20 M = MTOP, MBOT
+               K = KRCOL + 3*( M-1 )
+               IF( K.EQ.KTOP-1 ) THEN
+                  CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
+     $                         SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+     $                         V( 1, M ) )
+                  ALPHA = V( 1, M )
+                  CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M ) = H( K+2, K )
+                  V( 3, M ) = H( K+3, K )
+                  CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
+*
+*                 ==== A Bulge may collapse because of vigilant
+*                 .    deflation or destructive underflow.  (The
+*                 .    initial bulge is always collapsed.) Use
+*                 .    the two-small-subdiagonals trick to try
+*                 .    to get it started again. If V(2,M).NE.0 and
+*                 .    V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
+*                 .    this bulge is collapsing into a zero
+*                 .    subdiagonal.  It will be restarted next
+*                 .    trip through the loop.)
+*
+                  IF( V( 1, M ).NE.ZERO .AND.
+     $                ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
+     $                K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
+     $                 THEN
+*
+*                    ==== Typical case: not collapsed (yet). ====
+*
+                     H( K+1, K ) = BETA
+                     H( K+2, K ) = ZERO
+                     H( K+3, K ) = ZERO
+                  ELSE
+*
+*                    ==== Atypical case: collapsed.  Attempt to
+*                    .    reintroduce ignoring H(K+1,K).  If the
+*                    .    fill resulting from the new reflector
+*                    .    is too large, then abandon it.
+*                    .    Otherwise, use the new one. ====
+*
+                     CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ),
+     $                            SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+     $                            VT )
+                     SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) +
+     $                     ABS( VT( 3 ) )
+                     IF( SCL.NE.ZERO ) THEN
+                        VT( 1 ) = VT( 1 ) / SCL
+                        VT( 2 ) = VT( 2 ) / SCL
+                        VT( 3 ) = VT( 3 ) / SCL
+                     END IF
+*
+*                    ==== The following is the traditional and
+*                    .    conservative two-small-subdiagonals
+*                    .    test.  ====
+*                    .
+                     IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+
+     $                   ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )*
+     $                   ( ABS( H( K, K ) )+ABS( H( K+1,
+     $                   K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
+*
+*                       ==== Starting a new bulge here would
+*                       .    create non-negligible fill.   If
+*                       .    the old reflector is diagonal (only
+*                       .    possible with underflows), then
+*                       .    change it to I.  Otherwise, use
+*                       .    it with trepidation. ====
+*
+                        IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
+     $                       THEN
+                           V( 1, M ) = ZERO
+                        ELSE
+                           H( K+1, K ) = BETA
+                           H( K+2, K ) = ZERO
+                           H( K+3, K ) = ZERO
+                        END IF
+                     ELSE
+*
+*                       ==== Stating a new bulge here would
+*                       .    create only negligible fill.
+*                       .    Replace the old reflector with
+*                       .    the new one. ====
+*
+                        ALPHA = VT( 1 )
+                        CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
+                        REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) +
+     $                           H( K+3, K )*VT( 3 )
+                        H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM
+                        H( K+2, K ) = ZERO
+                        H( K+3, K ) = ZERO
+                        V( 1, M ) = VT( 1 )
+                        V( 2, M ) = VT( 2 )
+                        V( 3, M ) = VT( 3 )
+                     END IF
+                  END IF
+               END IF
+   20       CONTINUE
+*
+*           ==== Generate a 2-by-2 reflection, if needed. ====
+*
+            K = KRCOL + 3*( M22-1 )
+            IF( BMP22 ) THEN
+               IF( K.EQ.KTOP-1 ) THEN
+                  CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
+     $                         SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
+     $                         V( 1, M22 ) )
+                  BETA = V( 1, M22 )
+                  CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M22 ) = H( K+2, K )
+                  CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+                  H( K+1, K ) = BETA
+                  H( K+2, K ) = ZERO
+               END IF
+            ELSE
+*
+*              ==== Initialize V(1,M22) here to avoid possible undefined
+*              .    variable problems later. ====
+*
+               V( 1, M22 ) = ZERO
+            END IF
+*
+*           ==== Multiply H by reflections from the left ====
+*
+            IF( ACCUM ) THEN
+               JBOT = MIN( NDCOL, KBOT )
+            ELSE IF( WANTT ) THEN
+               JBOT = N
+            ELSE
+               JBOT = KBOT
+            END IF
+            DO 40 J = MAX( KTOP, KRCOL ), JBOT
+               MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
+               DO 30 M = MTOP, MEND
+                  K = KRCOL + 3*( M-1 )
+                  REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )*
+     $                     H( K+2, J )+V( 3, M )*H( K+3, J ) )
+                  H( K+1, J ) = H( K+1, J ) - REFSUM
+                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
+                  H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
+   30          CONTINUE
+   40       CONTINUE
+            IF( BMP22 ) THEN
+               K = KRCOL + 3*( M22-1 )
+               DO 50 J = MAX( K+1, KTOP ), JBOT
+                  REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )*
+     $                     H( K+2, J ) )
+                  H( K+1, J ) = H( K+1, J ) - REFSUM
+                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
+   50          CONTINUE
+            END IF
+*
+*           ==== Multiply H by reflections from the right.
+*           .    Delay filling in the last row until the
+*           .    vigilant deflation check is complete. ====
+*
+            IF( ACCUM ) THEN
+               JTOP = MAX( KTOP, INCOL )
+            ELSE IF( WANTT ) THEN
+               JTOP = 1
+            ELSE
+               JTOP = KTOP
+            END IF
+            DO 90 M = MTOP, MBOT
+               IF( V( 1, M ).NE.ZERO ) THEN
+                  K = KRCOL + 3*( M-1 )
+                  DO 60 J = JTOP, MIN( KBOT, K+3 )
+                     REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
+     $                        H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
+                     H( J, K+1 ) = H( J, K+1 ) - REFSUM
+                     H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M )
+                     H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )
+   60             CONTINUE
+*
+                  IF( ACCUM ) THEN
+*
+*                    ==== Accumulate U. (If necessary, update Z later
+*                    .    with with an efficient matrix-matrix
+*                    .    multiply.) ====
+*
+                     KMS = K - INCOL
+                     DO 70 J = MAX( 1, KTOP-INCOL ), KDU
+                        REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
+     $                           U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
+                        U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+                        U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M )
+                        U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )
+   70                CONTINUE
+                  ELSE IF( WANTZ ) THEN
+*
+*                    ==== U is not accumulated, so update Z
+*                    .    now by multiplying by reflections
+*                    .    from the right. ====
+*
+                     DO 80 J = ILOZ, IHIZ
+                        REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
+     $                           Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
+                        Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+                        Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M )
+                        Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )
+   80                CONTINUE
+                  END IF
+               END IF
+   90       CONTINUE
+*
+*           ==== Special case: 2-by-2 reflection (if needed) ====
+*
+            K = KRCOL + 3*( M22-1 )
+            IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
+               DO 100 J = JTOP, MIN( KBOT, K+3 )
+                  REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
+     $                     H( J, K+2 ) )
+                  H( J, K+1 ) = H( J, K+1 ) - REFSUM
+                  H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )
+  100          CONTINUE
+*
+               IF( ACCUM ) THEN
+                  KMS = K - INCOL
+                  DO 110 J = MAX( 1, KTOP-INCOL ), KDU
+                     REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
+     $                        U( J, KMS+2 ) )
+                     U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+                     U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )
+  110             CONTINUE
+               ELSE IF( WANTZ ) THEN
+                  DO 120 J = ILOZ, IHIZ
+                     REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
+     $                        Z( J, K+2 ) )
+                     Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+                     Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )
+  120             CONTINUE
+               END IF
+            END IF
+*
+*           ==== Vigilant deflation check ====
+*
+            MSTART = MTOP
+            IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
+     $         MSTART = MSTART + 1
+            MEND = MBOT
+            IF( BMP22 )
+     $         MEND = MEND + 1
+            IF( KRCOL.EQ.KBOT-2 )
+     $         MEND = MEND + 1
+            DO 130 M = MSTART, MEND
+               K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
+*
+*              ==== The following convergence test requires that
+*              .    the tradition small-compared-to-nearby-diagonals
+*              .    criterion and the Ahues & Tisseur (LAWN 122, 1997)
+*              .    criteria both be satisfied.  The latter improves
+*              .    accuracy in some examples. Falling back on an
+*              .    alternate convergence criterion when TST1 or TST2
+*              .    is zero (as done here) is traditional but probably
+*              .    unnecessary. ====
+*
+               IF( H( K+1, K ).NE.ZERO ) THEN
+                  TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )
+                  IF( TST1.EQ.ZERO ) THEN
+                     IF( K.GE.KTOP+1 )
+     $                  TST1 = TST1 + ABS( H( K, K-1 ) )
+                     IF( K.GE.KTOP+2 )
+     $                  TST1 = TST1 + ABS( H( K, K-2 ) )
+                     IF( K.GE.KTOP+3 )
+     $                  TST1 = TST1 + ABS( H( K, K-3 ) )
+                     IF( K.LE.KBOT-2 )
+     $                  TST1 = TST1 + ABS( H( K+2, K+1 ) )
+                     IF( K.LE.KBOT-3 )
+     $                  TST1 = TST1 + ABS( H( K+3, K+1 ) )
+                     IF( K.LE.KBOT-4 )
+     $                  TST1 = TST1 + ABS( H( K+4, K+1 ) )
+                  END IF
+                  IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
+     $                 THEN
+                     H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+                     H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+                     H11 = MAX( ABS( H( K+1, K+1 ) ),
+     $                     ABS( H( K, K )-H( K+1, K+1 ) ) )
+                     H22 = MIN( ABS( H( K+1, K+1 ) ),
+     $                     ABS( H( K, K )-H( K+1, K+1 ) ) )
+                     SCL = H11 + H12
+                     TST2 = H22*( H11 / SCL )
+*
+                     IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE.
+     $                   MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
+                  END IF
+               END IF
+  130       CONTINUE
+*
+*           ==== Fill in the last row of each bulge. ====
+*
+            MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
+            DO 140 M = MTOP, MEND
+               K = KRCOL + 3*( M-1 )
+               REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
+               H( K+4, K+1 ) = -REFSUM
+               H( K+4, K+2 ) = -REFSUM*V( 2, M )
+               H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )
+  140       CONTINUE
+*
+*           ==== End of near-the-diagonal bulge chase. ====
+*
+  150    CONTINUE
+*
+*        ==== Use U (if accumulated) to update far-from-diagonal
+*        .    entries in H.  If required, use U to update Z as
+*        .    well. ====
+*
+         IF( ACCUM ) THEN
+            IF( WANTT ) THEN
+               JTOP = 1
+               JBOT = N
+            ELSE
+               JTOP = KTOP
+               JBOT = KBOT
+            END IF
+            IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+     $          ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
+*
+*              ==== Updates not exploiting the 2-by-2 block
+*              .    structure of U.  K1 and NU keep track of
+*              .    the location and size of U in the special
+*              .    cases of introducing bulges and chasing
+*              .    bulges off the bottom.  In these special
+*              .    cases and in case the number of shifts
+*              .    is NS = 2, there is no 2-by-2 block
+*              .    structure to exploit.  ====
+*
+               K1 = MAX( 1, KTOP-INCOL )
+               NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
+*
+*              ==== Horizontal Multiply ====
+*
+               DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+                  JLEN = MIN( NH, JBOT-JCOL+1 )
+                  CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+     $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+     $                        LDWH )
+                  CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH,
+     $                         H( INCOL+K1, JCOL ), LDH )
+  160          CONTINUE
+*
+*              ==== Vertical multiply ====
+*
+               DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
+                  JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
+                  CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+     $                        LDU, ZERO, WV, LDWV )
+                  CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
+     $                         H( JROW, INCOL+K1 ), LDH )
+  170          CONTINUE
+*
+*              ==== Z multiply (also vertical) ====
+*
+               IF( WANTZ ) THEN
+                  DO 180 JROW = ILOZ, IHIZ, NV
+                     JLEN = MIN( NV, IHIZ-JROW+1 )
+                     CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+     $                           LDU, ZERO, WV, LDWV )
+                     CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
+     $                            Z( JROW, INCOL+K1 ), LDZ )
+  180             CONTINUE
+               END IF
+            ELSE
+*
+*              ==== Updates exploiting U's 2-by-2 block structure.
+*              .    (I2, I4, J2, J4 are the last rows and columns
+*              .    of the blocks.) ====
+*
+               I2 = ( KDU+1 ) / 2
+               I4 = KDU
+               J2 = I4 - I2
+               J4 = KDU
+*
+*              ==== KZS and KNZ deal with the band of zeros
+*              .    along the diagonal of one of the triangular
+*              .    blocks. ====
+*
+               KZS = ( J4-J2 ) - ( NS+1 )
+               KNZ = NS + 1
+*
+*              ==== Horizontal multiply ====
+*
+               DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+                  JLEN = MIN( NH, JBOT-JCOL+1 )
+*
+*                 ==== Copy bottom of H to top+KZS of scratch ====
+*                  (The first KZS rows get multiplied by zero.) ====
+*
+                  CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+     $                         LDH, WH( KZS+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+                  CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+     $                        LDWH )
+*
+*                 ==== Multiply top of H by U11' ====
+*
+                  CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+     $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+*                 ==== Copy top of H bottom of WH ====
+*
+                  CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+     $                         WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+     $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+     $                        U( J2+1, I2+1 ), LDU,
+     $                        H( INCOL+1+J2, JCOL ), LDH, ONE,
+     $                        WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Copy it back ====
+*
+                  CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH,
+     $                         H( INCOL+1, JCOL ), LDH )
+  190          CONTINUE
+*
+*              ==== Vertical multiply ====
+*
+               DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
+                  JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
+*
+*                 ==== Copy right of H to scratch (the first KZS
+*                 .    columns get multiplied by zero) ====
+*
+                  CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+     $                         LDH, WV( 1, 1+KZS ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+                  CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                        LDWV )
+*
+*                 ==== Multiply by U11 ====
+*
+                  CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                        H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
+     $                        LDWV )
+*
+*                 ==== Copy left of H to right of scratch ====
+*
+                  CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+     $                         WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                        H( JROW, INCOL+1+J2 ), LDH,
+     $                        U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
+     $                        LDWV )
+*
+*                 ==== Copy it back ====
+*
+                  CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                         H( JROW, INCOL+1 ), LDH )
+  200          CONTINUE
+*
+*              ==== Multiply Z (also vertical) ====
+*
+               IF( WANTZ ) THEN
+                  DO 210 JROW = ILOZ, IHIZ, NV
+                     JLEN = MIN( NV, IHIZ-JROW+1 )
+*
+*                    ==== Copy right of Z to left of scratch (first
+*                    .     KZS columns get multiplied by zero) ====
+*
+                     CALL DLACPY( 'ALL', JLEN, KNZ,
+     $                            Z( JROW, INCOL+1+J2 ), LDZ,
+     $                            WV( 1, 1+KZS ), LDWV )
+*
+*                    ==== Multiply by U12 ====
+*
+                     CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+     $                            LDWV )
+                     CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U11 ====
+*
+                     CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                           Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
+     $                           WV, LDWV )
+*
+*                    ==== Copy left of Z to right of scratch ====
+*
+                     CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+     $                            LDZ, WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Multiply by U21 ====
+*
+                     CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U22 ====
+*
+                     CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                           Z( JROW, INCOL+1+J2 ), LDZ,
+     $                           U( J2+1, I2+1 ), LDU, ONE,
+     $                           WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Copy the result back to Z ====
+*
+                     CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                            Z( JROW, INCOL+1 ), LDZ )
+  210             CONTINUE
+               END IF
+            END IF
+         END IF
+  220 CONTINUE
+*
+*     ==== End of DLAQR5 ====
+*
+      END
diff --git a/src/lib/lapack/dlarf.f b/src/lib/lapack/dlarf.f
new file mode 100644
index 00000000..22edc899
--- /dev/null
+++ b/src/lib/lapack/dlarf.f
@@ -0,0 +1,115 @@
+      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARF applies a real elementary reflector H to a real m by n matrix
+*  C, from either the left or the right. H is represented in the form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a real scalar and v is a real vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) DOUBLE PRECISION array, dimension
+*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*          The vector v in the representation of H. V is not used if
+*          TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of H.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C' * v
+*
+            CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
+     $                  WORK, 1 )
+*
+*           C := C - v * w'
+*
+            CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C * v
+*
+            CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+     $                  ZERO, WORK, 1 )
+*
+*           C := C - w * v'
+*
+            CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLARF
+*
+      END
diff --git a/src/lib/lapack/dlarfb.f b/src/lib/lapack/dlarfb.f
new file mode 100644
index 00000000..d4422473
--- /dev/null
+++ b/src/lib/lapack/dlarfb.f
@@ -0,0 +1,587 @@
+      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFB applies a real block reflector H or its transpose H' to a
+*  real m by n matrix C, from either the left or the right.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'T': apply H' (Transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  V       (input) DOUBLE PRECISION array, dimension
+*                                (LDV,K) if STOREV = 'C'
+*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
+*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+*          if STOREV = 'R', LDV >= K.
+*
+*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
+*          The triangular k by k matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DTRMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( STOREV, 'C' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1 )    (first K rows)
+*                     ( V2 )
+*           where  V1  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+     $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+     $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, N
+                     C( J, I ) = C( J, I ) - WORK( I, J )
+   20             CONTINUE
+   30          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+   50             CONTINUE
+   60          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1 )
+*                     ( V2 )    (last K rows)
+*           where  V2  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+     $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+     $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+   80             CONTINUE
+   90          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+     $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  110             CONTINUE
+  120          CONTINUE
+            END IF
+         END IF
+*
+      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1  V2 )    (V1: first K columns)
+*           where  V1  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+     $                        WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, N
+                     C( J, I ) = C( J, I ) - WORK( I, J )
+  140             CONTINUE
+  150          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+     $                     ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+  170             CONTINUE
+  180          CONTINUE
+*
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1  V2 )    (V2: last K columns)
+*           where  V2  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+     $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+     $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+     $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+  200             CONTINUE
+  210          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+     $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLARFB
+*
+      END
diff --git a/src/lib/lapack/dlarfg.f b/src/lib/lapack/dlarfg.f
new file mode 100644
index 00000000..be981880
--- /dev/null
+++ b/src/lib/lapack/dlarfg.f
@@ -0,0 +1,137 @@
+      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFG generates a real elementary reflector H of order n, such
+*  that
+*
+*        H * ( alpha ) = ( beta ),   H' * H = I.
+*            (   x   )   (   0  )
+*
+*  where alpha and beta are scalars, and x is an (n-1)-element real
+*  vector. H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( v )
+*
+*  where tau is a real scalar and v is a real (n-1)-element
+*  vector.
+*
+*  If the elements of x are all zero, then tau = 0 and H is taken to be
+*  the unit matrix.
+*
+*  Otherwise  1 <= tau <= 2.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the elementary reflector.
+*
+*  ALPHA   (input/output) DOUBLE PRECISION
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension
+*                         (1+(N-2)*abs(INCX))
+*          On entry, the vector x.
+*          On exit, it is overwritten with the vector v.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  TAU     (output) DOUBLE PRECISION
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      DOUBLE PRECISION   BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2, DNRM2
+      EXTERNAL           DLAMCH, DLAPY2, DNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.1 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DNRM2( N-1, X, INCX )
+*
+      IF( XNORM.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            RSAFMN = ONE / SAFMIN
+            KNT = 0
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL DSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHA = ALPHA*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DNRM2( N-1, X, INCX )
+            BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+            TAU = ( BETA-ALPHA ) / BETA
+            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+*           If ALPHA is subnormal, it may lose relative accuracy
+*
+            ALPHA = BETA
+            DO 20 J = 1, KNT
+               ALPHA = ALPHA*SAFMIN
+   20       CONTINUE
+         ELSE
+            TAU = ( BETA-ALPHA ) / BETA
+            CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+            ALPHA = BETA
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLARFG
+*
+      END
diff --git a/src/lib/lapack/dlarft.f b/src/lib/lapack/dlarft.f
new file mode 100644
index 00000000..2cd115f4
--- /dev/null
+++ b/src/lib/lapack/dlarft.f
@@ -0,0 +1,217 @@
+      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFT forms the triangular factor T of a real block reflector H
+*  of order n, which is defined as a product of k elementary reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
+*                   ( v1  1    )                     (     1 v2 v2 v2 )
+*                   ( v1 v2  1 )                     (        1 v3 v3 )
+*                   ( v1 v2 v3 )
+*                   ( v1 v2 v3 )
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
+*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
+*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
+*                   (     1 v3 )
+*                   (        1 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         DO 20 I = 1, K
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 10 J = 1, I
+                  T( J, I ) = ZERO
+   10          CONTINUE
+            ELSE
+*
+*              general case
+*
+               VII = V( I, I )
+               V( I, I ) = ONE
+               IF( LSAME( STOREV, 'C' ) ) THEN
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+                  CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
+     $                        V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+     $                        T( 1, I ), 1 )
+               ELSE
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+                  CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+               END IF
+               V( I, I ) = VII
+*
+*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+            END IF
+   20    CONTINUE
+      ELSE
+         DO 40 I = K, 1, -1
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 30 J = I, K
+                  T( J, I ) = ZERO
+   30          CONTINUE
+            ELSE
+*
+*              general case
+*
+               IF( I.LT.K ) THEN
+                  IF( LSAME( STOREV, 'C' ) ) THEN
+                     VII = V( N-K+I, I )
+                     V( N-K+I, I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+                     CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
+     $                           V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
+     $                           T( I+1, I ), 1 )
+                     V( N-K+I, I ) = VII
+                  ELSE
+                     VII = V( I, N-K+I )
+                     V( I, N-K+I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+                     CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                           T( I+1, I ), 1 )
+                     V( I, N-K+I ) = VII
+                  END IF
+*
+*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+                  CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+               END IF
+               T( I, I ) = TAU( I )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLARFT
+*
+      END
diff --git a/src/lib/lapack/dlarfx.f b/src/lib/lapack/dlarfx.f
new file mode 100644
index 00000000..cc4654e0
--- /dev/null
+++ b/src/lib/lapack/dlarfx.f
@@ -0,0 +1,638 @@
+      SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARFX applies a real elementary reflector H to a real m by n
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a real scalar and v is a real vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix
+*
+*  This version uses inline code if H has order < 11.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'
+*                                     or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of H.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= (1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                      (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      DOUBLE PRECISION   SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+     $                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+*        w := C'*v
+*
+         CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
+     $               1 )
+*
+*        C := C - tau * v * w'
+*
+         CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+*        w := C * v
+*
+         CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+     $               WORK, 1 )
+*
+*        C := C - tau * w * v'
+*
+         CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*V( 1 )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*V1
+         V2 = V( 2 )
+         T2 = TAU*V2
+         V3 = V( 3 )
+         T3 = TAU*V3
+         V4 = V( 4 )
+         T4 = TAU*V4
+         V5 = V( 5 )
+         T5 = TAU*V5
+         V6 = V( 6 )
+         T6 = TAU*V6
+         V7 = V( 7 )
+         T7 = TAU*V7
+         V8 = V( 8 )
+         T8 = TAU*V8
+         V9 = V( 9 )
+         T9 = TAU*V9
+         V10 = V( 10 )
+         T10 = TAU*V10
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 CONTINUE
+      RETURN
+*
+*     End of DLARFX
+*
+      END
diff --git a/src/lib/lapack/dlartg.f b/src/lib/lapack/dlartg.f
new file mode 100644
index 00000000..eb807c1d
--- /dev/null
+++ b/src/lib/lapack/dlartg.f
@@ -0,0 +1,145 @@
+      SUBROUTINE DLARTG( F, G, CS, SN, R )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   CS, F, G, R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARTG generate a plane rotation so that
+*
+*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
+*     [ -SN  CS  ]     [ G ]     [ 0 ]
+*
+*  This is a slower, more accurate version of the BLAS1 routine DROTG,
+*  with the following other differences:
+*     F and G are unchanged on return.
+*     If G=0, then CS=1 and SN=0.
+*     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
+*        floating point operations (saves work in DBDSQR when
+*        there are zeros on the diagonal).
+*
+*  If F exceeds G in magnitude, CS will be positive.
+*
+*  Arguments
+*  =========
+*
+*  F       (input) DOUBLE PRECISION
+*          The first component of vector to be rotated.
+*
+*  G       (input) DOUBLE PRECISION
+*          The second component of vector to be rotated.
+*
+*  CS      (output) DOUBLE PRECISION
+*          The cosine of the rotation.
+*
+*  SN      (output) DOUBLE PRECISION
+*          The sine of the rotation.
+*
+*  R       (output) DOUBLE PRECISION
+*          The nonzero component of the rotated vector.
+*
+*  This version has a few statements commented out for thread safety
+*  (machine parameters are computed on each entry). 10 feb 03, SJH.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+*     LOGICAL            FIRST
+      INTEGER            COUNT, I
+      DOUBLE PRECISION   EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, INT, LOG, MAX, SQRT
+*     ..
+*     .. Save statement ..
+*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
+*     ..
+*     .. Data statements ..
+*     DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+*     IF( FIRST ) THEN
+         SAFMIN = DLAMCH( 'S' )
+         EPS = DLAMCH( 'E' )
+         SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( DLAMCH( 'B' ) ) / TWO )
+         SAFMX2 = ONE / SAFMN2
+*        FIRST = .FALSE.
+*     END IF
+      IF( G.EQ.ZERO ) THEN
+         CS = ONE
+         SN = ZERO
+         R = F
+      ELSE IF( F.EQ.ZERO ) THEN
+         CS = ZERO
+         SN = ONE
+         R = G
+      ELSE
+         F1 = F
+         G1 = G
+         SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+         IF( SCALE.GE.SAFMX2 ) THEN
+            COUNT = 0
+   10       CONTINUE
+            COUNT = COUNT + 1
+            F1 = F1*SAFMN2
+            G1 = G1*SAFMN2
+            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+            IF( SCALE.GE.SAFMX2 )
+     $         GO TO 10
+            R = SQRT( F1**2+G1**2 )
+            CS = F1 / R
+            SN = G1 / R
+            DO 20 I = 1, COUNT
+               R = R*SAFMX2
+   20       CONTINUE
+         ELSE IF( SCALE.LE.SAFMN2 ) THEN
+            COUNT = 0
+   30       CONTINUE
+            COUNT = COUNT + 1
+            F1 = F1*SAFMX2
+            G1 = G1*SAFMX2
+            SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+            IF( SCALE.LE.SAFMN2 )
+     $         GO TO 30
+            R = SQRT( F1**2+G1**2 )
+            CS = F1 / R
+            SN = G1 / R
+            DO 40 I = 1, COUNT
+               R = R*SAFMN2
+   40       CONTINUE
+         ELSE
+            R = SQRT( F1**2+G1**2 )
+            CS = F1 / R
+            SN = G1 / R
+         END IF
+         IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
+            CS = -CS
+            SN = -SN
+            R = -R
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLARTG
+*
+      END
diff --git a/src/lib/lapack/dlarz.f b/src/lib/lapack/dlarz.f
new file mode 100644
index 00000000..b302fdc2
--- /dev/null
+++ b/src/lib/lapack/dlarz.f
@@ -0,0 +1,152 @@
+      SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, L, LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARZ applies a real elementary reflector H to a real M-by-N
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a real scalar and v is a real vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*
+*  H is a product of k elementary reflectors as returned by DTZRZF.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  L       (input) INTEGER
+*          The number of entries of the vector V containing
+*          the meaningful part of the Householder vectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  V       (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
+*          The vector v in the representation of H as returned by
+*          DTZRZF. V is not used if TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of H.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w( 1:n ) = C( 1, 1:n )
+*
+            CALL DCOPY( N, C, LDC, WORK, 1 )
+*
+*           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
+*
+            CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
+     $                  INCV, ONE, WORK, 1 )
+*
+*           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
+*
+            CALL DAXPY( N, -TAU, WORK, 1, C, LDC )
+*
+*           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+*                               tau * v( 1:l ) * w( 1:n )'
+*
+            CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
+     $                 LDC )
+         END IF
+*
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w( 1:m ) = C( 1:m, 1 )
+*
+            CALL DCOPY( M, C, 1, WORK, 1 )
+*
+*           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+            CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
+     $                  V, INCV, ONE, WORK, 1 )
+*
+*           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
+*
+            CALL DAXPY( M, -TAU, WORK, 1, C, 1 )
+*
+*           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+*                               tau * w( 1:m ) * v( 1:l )'
+*
+            CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+     $                 LDC )
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLARZ
+*
+      END
diff --git a/src/lib/lapack/dlarzb.f b/src/lib/lapack/dlarzb.f
new file mode 100644
index 00000000..ec59d8d5
--- /dev/null
+++ b/src/lib/lapack/dlarzb.f
@@ -0,0 +1,220 @@
+      SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
+     $                   LDV, T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, L, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARZB applies a real block reflector H or its transpose H**T to
+*  a real distributed M-by-N  C from the left or the right.
+*
+*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'C': apply H' (Transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise                        (not supported yet)
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix V containing the
+*          meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  V       (input) DOUBLE PRECISION array, dimension (LDV,NV).
+*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
+*
+*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)
+*          The triangular K-by-K matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DTRMM, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+*     Check for currently supported options
+*
+      INFO = 0
+      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLARZB', -INFO )
+         RETURN
+      END IF
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'T'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C  or  H' * C
+*
+*        W( 1:n, 1:k ) = C( 1:k, 1:n )'
+*
+         DO 10 J = 1, K
+            CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10    CONTINUE
+*
+*        W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
+*                        C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
+*
+         IF( L.GT.0 )
+     $      CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
+     $                  C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+*        W( 1:n, 1:k ) = W( 1:n, 1:k ) * T'  or  W( 1:m, 1:k ) * T
+*
+         CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
+     $               LDT, WORK, LDWORK )
+*
+*        C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, K
+               C( I, J ) = C( I, J ) - WORK( J, I )
+   20       CONTINUE
+   30    CONTINUE
+*
+*        C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+*                            V( 1:k, 1:l )' * W( 1:n, 1:k )'
+*
+         IF( L.GT.0 )
+     $      CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
+     $                  WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        Form  C * H  or  C * H'
+*
+*        W( 1:m, 1:k ) = C( 1:m, 1:k )
+*
+         DO 40 J = 1, K
+            CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40    CONTINUE
+*
+*        W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
+*                        C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
+*
+         IF( L.GT.0 )
+     $      CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
+     $                  C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+*        W( 1:m, 1:k ) = W( 1:m, 1:k ) * T  or  W( 1:m, 1:k ) * T'
+*
+         CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
+     $               LDT, WORK, LDWORK )
+*
+*        C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
+*
+         DO 60 J = 1, K
+            DO 50 I = 1, M
+               C( I, J ) = C( I, J ) - WORK( I, J )
+   50       CONTINUE
+   60    CONTINUE
+*
+*        C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+*                            W( 1:m, 1:k ) * V( 1:k, 1:l )
+*
+         IF( L.GT.0 )
+     $      CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
+     $                  WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLARZB
+*
+      END
diff --git a/src/lib/lapack/dlarzt.f b/src/lib/lapack/dlarzt.f
new file mode 100644
index 00000000..d79636e0
--- /dev/null
+++ b/src/lib/lapack/dlarzt.f
@@ -0,0 +1,184 @@
+      SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLARZT forms the triangular factor T of a real block reflector
+*  H of order > n, which is defined as a product of k elementary
+*  reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise                        (not supported yet)
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) DOUBLE PRECISION array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*                                              ______V_____
+*         ( v1 v2 v3 )                        /            \
+*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
+*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
+*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
+*         ( v1 v2 v3 )
+*            .  .  .
+*            .  .  .
+*            1  .  .
+*               1  .
+*                  1
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*                                                        ______V_____
+*            1                                          /            \
+*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
+*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
+*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
+*            .  .  .
+*         ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*     V = ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DTRMV, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Check for currently supported options
+*
+      INFO = 0
+      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLARZT', -INFO )
+         RETURN
+      END IF
+*
+      DO 20 I = K, 1, -1
+         IF( TAU( I ).EQ.ZERO ) THEN
+*
+*           H(i)  =  I
+*
+            DO 10 J = I, K
+               T( J, I ) = ZERO
+   10       CONTINUE
+         ELSE
+*
+*           general case
+*
+            IF( I.LT.K ) THEN
+*
+*              T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
+*
+               CALL DGEMV( 'No transpose', K-I, N, -TAU( I ),
+     $                     V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                     T( I+1, I ), 1 )
+*
+*              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+               CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                     T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+            END IF
+            T( I, I ) = TAU( I )
+         END IF
+   20 CONTINUE
+      RETURN
+*
+*     End of DLARZT
+*
+      END
diff --git a/src/lib/lapack/dlas2.f b/src/lib/lapack/dlas2.f
new file mode 100644
index 00000000..e100a4d8
--- /dev/null
+++ b/src/lib/lapack/dlas2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   F, G, H, SSMAX, SSMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAS2  computes the singular values of the 2-by-2 matrix
+*     [  F   G  ]
+*     [  0   H  ].
+*  On return, SSMIN is the smaller singular value and SSMAX is the
+*  larger singular value.
+*
+*  Arguments
+*  =========
+*
+*  F       (input) DOUBLE PRECISION
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  G       (input) DOUBLE PRECISION
+*          The (1,2) element of the 2-by-2 matrix.
+*
+*  H       (input) DOUBLE PRECISION
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  SSMIN   (output) DOUBLE PRECISION
+*          The smaller singular value.
+*
+*  SSMAX   (output) DOUBLE PRECISION
+*          The larger singular value.
+*
+*  Further Details
+*  ===============
+*
+*  Barring over/underflow, all output quantities are correct to within
+*  a few units in the last place (ulps), even in the absence of a guard
+*  digit in addition/subtraction.
+*
+*  In IEEE arithmetic, the code works correctly if one matrix element is
+*  infinite.
+*
+*  Overflow will not occur unless the largest singular value itself
+*  overflows, or is within a few ulps of overflow. (On machines with
+*  partial overflow, like the Cray, overflow may occur if the largest
+*  singular value is within a factor of 2 of overflow.)
+*
+*  Underflow is harmless if underflow is gradual. Otherwise, results
+*  may correspond to a matrix modified by perturbations of size near
+*  the underflow threshold.
+*
+*  ====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      FA = ABS( F )
+      GA = ABS( G )
+      HA = ABS( H )
+      FHMN = MIN( FA, HA )
+      FHMX = MAX( FA, HA )
+      IF( FHMN.EQ.ZERO ) THEN
+         SSMIN = ZERO
+         IF( FHMX.EQ.ZERO ) THEN
+            SSMAX = GA
+         ELSE
+            SSMAX = MAX( FHMX, GA )*SQRT( ONE+
+     $              ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
+         END IF
+      ELSE
+         IF( GA.LT.FHMX ) THEN
+            AS = ONE + FHMN / FHMX
+            AT = ( FHMX-FHMN ) / FHMX
+            AU = ( GA / FHMX )**2
+            C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
+            SSMIN = FHMN*C
+            SSMAX = FHMX / C
+         ELSE
+            AU = FHMX / GA
+            IF( AU.EQ.ZERO ) THEN
+*
+*              Avoid possible harmful underflow if exponent range
+*              asymmetric (true SSMIN may not underflow even if
+*              AU underflows)
+*
+               SSMIN = ( FHMN*FHMX ) / GA
+               SSMAX = GA
+            ELSE
+               AS = ONE + FHMN / FHMX
+               AT = ( FHMX-FHMN ) / FHMX
+               C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
+     $             SQRT( ONE+( AT*AU )**2 ) )
+               SSMIN = ( FHMN*C )*AU
+               SSMIN = SSMIN + SSMIN
+               SSMAX = GA / ( C+C )
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of DLAS2
+*
+      END
diff --git a/src/lib/lapack/dlascl.f b/src/lib/lapack/dlascl.f
new file mode 100644
index 00000000..7a7a78fd
--- /dev/null
+++ b/src/lib/lapack/dlascl.f
@@ -0,0 +1,267 @@
+      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TYPE
+      INTEGER            INFO, KL, KU, LDA, M, N
+      DOUBLE PRECISION   CFROM, CTO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASCL multiplies the M by N real matrix A by the real scalar
+*  CTO/CFROM.  This is done without over/underflow as long as the final
+*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
+*  A may be full, upper triangular, lower triangular, upper Hessenberg,
+*  or banded.
+*
+*  Arguments
+*  =========
+*
+*  TYPE    (input) CHARACTER*1
+*          TYPE indices the storage type of the input matrix.
+*          = 'G':  A is a full matrix.
+*          = 'L':  A is a lower triangular matrix.
+*          = 'U':  A is an upper triangular matrix.
+*          = 'H':  A is an upper Hessenberg matrix.
+*          = 'B':  A is a symmetric band matrix with lower bandwidth KL
+*                  and upper bandwidth KU and with the only the lower
+*                  half stored.
+*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
+*                  and upper bandwidth KU and with the only the upper
+*                  half stored.
+*          = 'Z':  A is a band matrix with lower bandwidth KL and upper
+*                  bandwidth KU.
+*
+*  KL      (input) INTEGER
+*          The lower bandwidth of A.  Referenced only if TYPE = 'B',
+*          'Q' or 'Z'.
+*
+*  KU      (input) INTEGER
+*          The upper bandwidth of A.  Referenced only if TYPE = 'B',
+*          'Q' or 'Z'.
+*
+*  CFROM   (input) DOUBLE PRECISION
+*  CTO     (input) DOUBLE PRECISION
+*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
+*          without over/underflow if the final result CTO*A(I,J)/CFROM
+*          can be represented without over/underflow.  CFROM must be
+*          nonzero.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
+*          storage type.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          0  - successful exit
+*          <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO ) THEN
+         INFO = -4
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      CTO1 = CTOC / BIGNUM
+      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CFROMC = CFROM1
+      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CTOC = CTO1
+      ELSE
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of DLASCL
+*
+      END
diff --git a/src/lib/lapack/dlaset.f b/src/lib/lapack/dlaset.f
new file mode 100644
index 00000000..fc7bc2f5
--- /dev/null
+++ b/src/lib/lapack/dlaset.f
@@ -0,0 +1,114 @@
+      SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, M, N
+      DOUBLE PRECISION   ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASET initializes an m-by-n matrix A to BETA on the diagonal and
+*  ALPHA on the offdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the part of the matrix A to be set.
+*          = 'U':      Upper triangular part is set; the strictly lower
+*                      triangular part of A is not changed.
+*          = 'L':      Lower triangular part is set; the strictly upper
+*                      triangular part of A is not changed.
+*          Otherwise:  All of the matrix A is set.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  ALPHA   (input) DOUBLE PRECISION
+*          The constant to which the offdiagonal elements are to be set.
+*
+*  BETA    (input) DOUBLE PRECISION
+*          The constant to which the diagonal elements are to be set.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On exit, the leading m-by-n submatrix of A is set as follows:
+*
+*          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
+*          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
+*          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
+*
+*          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Set the strictly upper triangular or trapezoidal part of the
+*        array to ALPHA.
+*
+         DO 20 J = 2, N
+            DO 10 I = 1, MIN( J-1, M )
+               A( I, J ) = ALPHA
+   10       CONTINUE
+   20    CONTINUE
+*
+      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+*
+*        Set the strictly lower triangular or trapezoidal part of the
+*        array to ALPHA.
+*
+         DO 40 J = 1, MIN( M, N )
+            DO 30 I = J + 1, M
+               A( I, J ) = ALPHA
+   30       CONTINUE
+   40    CONTINUE
+*
+      ELSE
+*
+*        Set the leading m-by-n submatrix to ALPHA.
+*
+         DO 60 J = 1, N
+            DO 50 I = 1, M
+               A( I, J ) = ALPHA
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+*     Set the first min(M,N) diagonal elements to BETA.
+*
+      DO 70 I = 1, MIN( M, N )
+         A( I, I ) = BETA
+   70 CONTINUE
+*
+      RETURN
+*
+*     End of DLASET
+*
+      END
diff --git a/src/lib/lapack/dlasq1.f b/src/lib/lapack/dlasq1.f
new file mode 100644
index 00000000..6f4c3413
--- /dev/null
+++ b/src/lib/lapack/dlasq1.f
@@ -0,0 +1,148 @@
+      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ1 computes the singular values of a real N-by-N bidiagonal
+*  matrix with diagonal D and off-diagonal E. The singular values
+*  are computed to high relative accuracy, in the absence of
+*  denormalization, underflow and overflow. The algorithm was first
+*  presented in
+*
+*  "Accurate singular values and differential qd algorithms" by K. V.
+*  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
+*  1994,
+*
+*  and the present implementation is described in "An implementation of
+*  the dqds Algorithm (Positive Case)", LAPACK Working Note.
+*
+*  Arguments
+*  =========
+*
+*  N     (input) INTEGER
+*        The number of rows and columns in the matrix. N >= 0.
+*
+*  D     (input/output) DOUBLE PRECISION array, dimension (N)
+*        On entry, D contains the diagonal elements of the
+*        bidiagonal matrix whose SVD is desired. On normal exit,
+*        D contains the singular values in decreasing order.
+*
+*  E     (input/output) DOUBLE PRECISION array, dimension (N)
+*        On entry, elements E(1:N-1) contain the off-diagonal elements
+*        of the bidiagonal matrix whose SVD is desired.
+*        On exit, E is overwritten.
+*
+*  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+*  INFO  (output) INTEGER
+*        = 0: successful exit
+*        < 0: if INFO = -i, the i-th argument had an illegal value
+*        > 0: the algorithm failed
+*             = 1, a split was marked by a positive value in E
+*             = 2, current block of Z not diagonalized after 30*N
+*                  iterations (in inner while loop)
+*             = 3, termination criterion of outer while loop not met 
+*                  (program created more than N unreduced blocks)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO
+      DOUBLE PRECISION   EPS, SCALE, SAFMIN, SIGMN, SIGMX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -2
+         CALL XERBLA( 'DLASQ1', -INFO )
+         RETURN
+      ELSE IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+         D( 1 ) = ABS( D( 1 ) )
+         RETURN
+      ELSE IF( N.EQ.2 ) THEN
+         CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
+         D( 1 ) = SIGMX
+         D( 2 ) = SIGMN
+         RETURN
+      END IF
+*
+*     Estimate the largest singular value.
+*
+      SIGMX = ZERO
+      DO 10 I = 1, N - 1
+         D( I ) = ABS( D( I ) )
+         SIGMX = MAX( SIGMX, ABS( E( I ) ) )
+   10 CONTINUE
+      D( N ) = ABS( D( N ) )
+*
+*     Early return if SIGMX is zero (matrix is already diagonal).
+*
+      IF( SIGMX.EQ.ZERO ) THEN
+         CALL DLASRT( 'D', N, D, IINFO )
+         RETURN
+      END IF
+*
+      DO 20 I = 1, N
+         SIGMX = MAX( SIGMX, D( I ) )
+   20 CONTINUE
+*
+*     Copy D and E into WORK (in the Z format) and scale (squaring the
+*     input data makes scaling by a power of the radix pointless).
+*
+      EPS = DLAMCH( 'Precision' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      SCALE = SQRT( EPS / SAFMIN )
+      CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
+      CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
+      CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
+     $             IINFO )
+*         
+*     Compute the q's and e's.
+*
+      DO 30 I = 1, 2*N - 1
+         WORK( I ) = WORK( I )**2
+   30 CONTINUE
+      WORK( 2*N ) = ZERO
+*
+      CALL DLASQ2( N, WORK, INFO )
+*
+      IF( INFO.EQ.0 ) THEN
+         DO 40 I = 1, N
+            D( I ) = SQRT( WORK( I ) )
+   40    CONTINUE
+         CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
+      END IF
+*
+      RETURN
+*
+*     End of DLASQ1
+*
+      END
diff --git a/src/lib/lapack/dlasq2.f b/src/lib/lapack/dlasq2.f
new file mode 100644
index 00000000..b6b79aeb
--- /dev/null
+++ b/src/lib/lapack/dlasq2.f
@@ -0,0 +1,448 @@
+      SUBROUTINE DLASQ2( N, Z, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ2 computes all the eigenvalues of the symmetric positive 
+*  definite tridiagonal matrix associated with the qd array Z to high
+*  relative accuracy are computed to high relative accuracy, in the
+*  absence of denormalization, underflow and overflow.
+*
+*  To see the relation of Z to the tridiagonal matrix, let L be a
+*  unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
+*  let U be an upper bidiagonal matrix with 1's above and diagonal
+*  Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
+*  symmetric tridiagonal to which it is similar.
+*
+*  Note : DLASQ2 defines a logical variable, IEEE, which is true
+*  on machines which follow ieee-754 floating-point standard in their
+*  handling of infinities and NaNs, and false otherwise. This variable
+*  is passed to DLAZQ3.
+*
+*  Arguments
+*  =========
+*
+*  N     (input) INTEGER
+*        The number of rows and columns in the matrix. N >= 0.
+*
+*  Z     (workspace) DOUBLE PRECISION array, dimension ( 4*N )
+*        On entry Z holds the qd array. On exit, entries 1 to N hold
+*        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
+*        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
+*        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
+*        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
+*        shifts that failed.
+*
+*  INFO  (output) INTEGER
+*        = 0: successful exit
+*        < 0: if the i-th argument is a scalar and had an illegal
+*             value, then INFO = -i, if the i-th argument is an
+*             array and the j-entry had an illegal value, then
+*             INFO = -(i*100+j)
+*        > 0: the algorithm failed
+*              = 1, a split was marked by a positive value in E
+*              = 2, current block of Z not diagonalized after 30*N
+*                   iterations (in inner while loop)
+*              = 3, termination criterion of outer while loop not met 
+*                   (program created more than N unreduced blocks)
+*
+*  Further Details
+*  ===============
+*  Local Variables: I0:N0 defines a current unreduced segment of Z.
+*  The shifts are accumulated in SIGMA. Iteration count is in ITER.
+*  Ping-pong is controlled by PP (alternates between 0 and 1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   CBIAS
+      PARAMETER          ( CBIAS = 1.50D0 )
+      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, FOUR, HUNDRD
+      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
+     $                     TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            IEEE
+      INTEGER            I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, 
+     $                   N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
+      DOUBLE PRECISION   D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E,
+     $                   EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN,
+     $                   SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAZQ3, DLASRT, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH, ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*      
+*     Test the input arguments.
+*     (in case DLASQ2 is not called by DLASQ1)
+*
+      INFO = 0
+      EPS = DLAMCH( 'Precision' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      TOL = EPS*HUNDRD
+      TOL2 = TOL**2
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'DLASQ2', 1 )
+         RETURN
+      ELSE IF( N.EQ.0 ) THEN
+         RETURN
+      ELSE IF( N.EQ.1 ) THEN
+*
+*        1-by-1 case.
+*
+         IF( Z( 1 ).LT.ZERO ) THEN
+            INFO = -201
+            CALL XERBLA( 'DLASQ2', 2 )
+         END IF
+         RETURN
+      ELSE IF( N.EQ.2 ) THEN
+*
+*        2-by-2 case.
+*
+         IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
+            INFO = -2
+            CALL XERBLA( 'DLASQ2', 2 )
+            RETURN
+         ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
+            D = Z( 3 )
+            Z( 3 ) = Z( 1 )
+            Z( 1 ) = D
+         END IF
+         Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
+         IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
+            T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) ) 
+            S = Z( 3 )*( Z( 2 ) / T )
+            IF( S.LE.T ) THEN
+               S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+            ELSE
+               S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+            END IF
+            T = Z( 1 ) + ( S+Z( 2 ) )
+            Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
+            Z( 1 ) = T
+         END IF
+         Z( 2 ) = Z( 3 )
+         Z( 6 ) = Z( 2 ) + Z( 1 )
+         RETURN
+      END IF
+*
+*     Check for negative data and compute sums of q's and e's.
+*
+      Z( 2*N ) = ZERO
+      EMIN = Z( 2 )
+      QMAX = ZERO
+      ZMAX = ZERO
+      D = ZERO
+      E = ZERO
+*
+      DO 10 K = 1, 2*( N-1 ), 2
+         IF( Z( K ).LT.ZERO ) THEN
+            INFO = -( 200+K )
+            CALL XERBLA( 'DLASQ2', 2 )
+            RETURN
+         ELSE IF( Z( K+1 ).LT.ZERO ) THEN
+            INFO = -( 200+K+1 )
+            CALL XERBLA( 'DLASQ2', 2 )
+            RETURN
+         END IF
+         D = D + Z( K )
+         E = E + Z( K+1 )
+         QMAX = MAX( QMAX, Z( K ) )
+         EMIN = MIN( EMIN, Z( K+1 ) )
+         ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
+   10 CONTINUE
+      IF( Z( 2*N-1 ).LT.ZERO ) THEN
+         INFO = -( 200+2*N-1 )
+         CALL XERBLA( 'DLASQ2', 2 )
+         RETURN
+      END IF
+      D = D + Z( 2*N-1 )
+      QMAX = MAX( QMAX, Z( 2*N-1 ) )
+      ZMAX = MAX( QMAX, ZMAX )
+*
+*     Check for diagonality.
+*
+      IF( E.EQ.ZERO ) THEN
+         DO 20 K = 2, N
+            Z( K ) = Z( 2*K-1 )
+   20    CONTINUE
+         CALL DLASRT( 'D', N, Z, IINFO )
+         Z( 2*N-1 ) = D
+         RETURN
+      END IF
+*
+      TRACE = D + E
+*
+*     Check for zero data.
+*
+      IF( TRACE.EQ.ZERO ) THEN
+         Z( 2*N-1 ) = ZERO
+         RETURN
+      END IF
+*         
+*     Check whether the machine is IEEE conformable.
+*         
+      IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
+     $       ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1      
+*         
+*     Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
+*
+      DO 30 K = 2*N, 2, -2
+         Z( 2*K ) = ZERO 
+         Z( 2*K-1 ) = Z( K ) 
+         Z( 2*K-2 ) = ZERO 
+         Z( 2*K-3 ) = Z( K-1 ) 
+   30 CONTINUE
+*
+      I0 = 1
+      N0 = N
+*
+*     Reverse the qd-array, if warranted.
+*
+      IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
+         IPN4 = 4*( I0+N0 )
+         DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
+            TEMP = Z( I4-3 )
+            Z( I4-3 ) = Z( IPN4-I4-3 )
+            Z( IPN4-I4-3 ) = TEMP
+            TEMP = Z( I4-1 )
+            Z( I4-1 ) = Z( IPN4-I4-5 )
+            Z( IPN4-I4-5 ) = TEMP
+   40    CONTINUE
+      END IF
+*
+*     Initial split checking via dqd and Li's test.
+*
+      PP = 0
+*
+      DO 80 K = 1, 2
+*
+         D = Z( 4*N0+PP-3 )
+         DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
+            IF( Z( I4-1 ).LE.TOL2*D ) THEN
+               Z( I4-1 ) = -ZERO
+               D = Z( I4-3 )
+            ELSE
+               D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
+            END IF
+   50    CONTINUE
+*
+*        dqd maps Z to ZZ plus Li's test.
+*
+         EMIN = Z( 4*I0+PP+1 )
+         D = Z( 4*I0+PP-3 )
+         DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
+            Z( I4-2*PP-2 ) = D + Z( I4-1 )
+            IF( Z( I4-1 ).LE.TOL2*D ) THEN
+               Z( I4-1 ) = -ZERO
+               Z( I4-2*PP-2 ) = D
+               Z( I4-2*PP ) = ZERO
+               D = Z( I4+1 )
+            ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
+     $               SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
+               TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
+               Z( I4-2*PP ) = Z( I4-1 )*TEMP
+               D = D*TEMP
+            ELSE
+               Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
+               D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
+            END IF
+            EMIN = MIN( EMIN, Z( I4-2*PP ) )
+   60    CONTINUE 
+         Z( 4*N0-PP-2 ) = D
+*
+*        Now find qmax.
+*
+         QMAX = Z( 4*I0-PP-2 )
+         DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
+            QMAX = MAX( QMAX, Z( I4 ) )
+   70    CONTINUE
+*
+*        Prepare for the next iteration on K.
+*
+         PP = 1 - PP
+   80 CONTINUE
+*
+*     Initialise variables to pass to DLAZQ3
+*
+      TTYPE = 0
+      DMIN1 = ZERO
+      DMIN2 = ZERO
+      DN    = ZERO
+      DN1   = ZERO
+      DN2   = ZERO
+      TAU   = ZERO
+*
+      ITER = 2
+      NFAIL = 0
+      NDIV = 2*( N0-I0 )
+*
+      DO 140 IWHILA = 1, N + 1
+         IF( N0.LT.1 ) 
+     $      GO TO 150
+*
+*        While array unfinished do 
+*
+*        E(N0) holds the value of SIGMA when submatrix in I0:N0
+*        splits from the rest of the array, but is negated.
+*      
+         DESIG = ZERO
+         IF( N0.EQ.N ) THEN
+            SIGMA = ZERO
+         ELSE
+            SIGMA = -Z( 4*N0-1 )
+         END IF
+         IF( SIGMA.LT.ZERO ) THEN
+            INFO = 1
+            RETURN
+         END IF
+*
+*        Find last unreduced submatrix's top index I0, find QMAX and
+*        EMIN. Find Gershgorin-type bound if Q's much greater than E's.
+*
+         EMAX = ZERO 
+         IF( N0.GT.I0 ) THEN
+            EMIN = ABS( Z( 4*N0-5 ) )
+         ELSE
+            EMIN = ZERO
+         END IF
+         QMIN = Z( 4*N0-3 )
+         QMAX = QMIN
+         DO 90 I4 = 4*N0, 8, -4
+            IF( Z( I4-5 ).LE.ZERO )
+     $         GO TO 100
+            IF( QMIN.GE.FOUR*EMAX ) THEN
+               QMIN = MIN( QMIN, Z( I4-3 ) )
+               EMAX = MAX( EMAX, Z( I4-5 ) )
+            END IF
+            QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
+            EMIN = MIN( EMIN, Z( I4-5 ) )
+   90    CONTINUE
+         I4 = 4 
+*
+  100    CONTINUE
+         I0 = I4 / 4
+*
+*        Store EMIN for passing to DLAZQ3.
+*
+         Z( 4*N0-1 ) = EMIN
+*
+*        Put -(initial shift) into DMIN.
+*
+         DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
+*
+*        Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
+*
+         PP = 0 
+*
+         NBIG = 30*( N0-I0+1 )
+         DO 120 IWHILB = 1, NBIG
+            IF( I0.GT.N0 ) 
+     $         GO TO 130
+*
+*           While submatrix unfinished take a good dqds step.
+*
+            CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+     $                   ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+     $                   DN2, TAU )
+*
+            PP = 1 - PP
+*
+*           When EMIN is very small check for splits.
+*
+            IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
+               IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
+     $             Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
+                  SPLT = I0 - 1
+                  QMAX = Z( 4*I0-3 )
+                  EMIN = Z( 4*I0-1 )
+                  OLDEMN = Z( 4*I0 )
+                  DO 110 I4 = 4*I0, 4*( N0-3 ), 4
+                     IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
+     $                   Z( I4-1 ).LE.TOL2*SIGMA ) THEN
+                        Z( I4-1 ) = -SIGMA
+                        SPLT = I4 / 4
+                        QMAX = ZERO
+                        EMIN = Z( I4+3 )
+                        OLDEMN = Z( I4+4 )
+                     ELSE
+                        QMAX = MAX( QMAX, Z( I4+1 ) )
+                        EMIN = MIN( EMIN, Z( I4-1 ) )
+                        OLDEMN = MIN( OLDEMN, Z( I4 ) )
+                     END IF
+  110             CONTINUE
+                  Z( 4*N0-1 ) = EMIN
+                  Z( 4*N0 ) = OLDEMN
+                  I0 = SPLT + 1
+               END IF
+            END IF
+*
+  120    CONTINUE
+*
+         INFO = 2
+         RETURN
+*
+*        end IWHILB
+*
+  130    CONTINUE
+*
+  140 CONTINUE
+*
+      INFO = 3
+      RETURN
+*
+*     end IWHILA   
+*
+  150 CONTINUE
+*      
+*     Move q's to the front.
+*      
+      DO 160 K = 2, N
+         Z( K ) = Z( 4*K-3 )
+  160 CONTINUE
+*      
+*     Sort and compute sum of eigenvalues.
+*
+      CALL DLASRT( 'D', N, Z, IINFO )
+*
+      E = ZERO
+      DO 170 K = N, 1, -1
+         E = E + Z( K )
+  170 CONTINUE
+*
+*     Store trace, sum(eigenvalues) and information on performance.
+*
+      Z( 2*N+1 ) = TRACE 
+      Z( 2*N+2 ) = E
+      Z( 2*N+3 ) = DBLE( ITER )
+      Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
+      Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
+      RETURN
+*
+*     End of DLASQ2
+*
+      END
diff --git a/src/lib/lapack/dlasq3.f b/src/lib/lapack/dlasq3.f
new file mode 100644
index 00000000..ce4055d8
--- /dev/null
+++ b/src/lib/lapack/dlasq3.f
@@ -0,0 +1,295 @@
+      SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+     $                   ITER, NDIV, IEEE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            I0, ITER, N0, NDIV, NFAIL, PP
+      DOUBLE PRECISION   DESIG, DMIN, QMAX, SIGMA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+*  In case of failure it changes shifts, and tries again until output
+*  is positive.
+*
+*  Arguments
+*  =========
+*
+*  I0     (input) INTEGER
+*         First index.
+*
+*  N0     (input) INTEGER
+*         Last index.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( 4*N )
+*         Z holds the qd array.
+*
+*  PP     (input) INTEGER
+*         PP=0 for ping, PP=1 for pong.
+*
+*  DMIN   (output) DOUBLE PRECISION
+*         Minimum value of d.
+*
+*  SIGMA  (output) DOUBLE PRECISION
+*         Sum of shifts used in current segment.
+*
+*  DESIG  (input/output) DOUBLE PRECISION
+*         Lower order part of SIGMA
+*
+*  QMAX   (input) DOUBLE PRECISION
+*         Maximum value of q.
+*
+*  NFAIL  (output) INTEGER
+*         Number of times shift was too big.
+*
+*  ITER   (output) INTEGER
+*         Number of iterations.
+*
+*  NDIV   (output) INTEGER
+*         Number of divisions.
+*
+*  TTYPE  (output) INTEGER
+*         Shift type.
+*
+*  IEEE   (input) LOGICAL
+*         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   CBIAS
+      PARAMETER          ( CBIAS = 1.50D0 )
+      DOUBLE PRECISION   ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+      PARAMETER          ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
+     $                     ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IPN4, J4, N0IN, NN, TTYPE
+      DOUBLE PRECISION   DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
+     $                   TAU, TEMP, TOL, TOL2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASQ4, DLASQ5, DLASQ6
+*     ..
+*     .. External Function ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Save statement ..
+      SAVE               TTYPE
+      SAVE               DMIN1, DMIN2, DN, DN1, DN2, TAU
+*     ..
+*     .. Data statement ..
+      DATA               TTYPE / 0 /
+      DATA               DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
+     $                   DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
+*     ..
+*     .. Executable Statements ..
+*
+      N0IN = N0
+      EPS = DLAMCH( 'Precision' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      TOL = EPS*HUNDRD
+      TOL2 = TOL**2
+*
+*     Check for deflation.
+*
+   10 CONTINUE
+*
+      IF( N0.LT.I0 )
+     $   RETURN
+      IF( N0.EQ.I0 )
+     $   GO TO 20
+      NN = 4*N0 + PP
+      IF( N0.EQ.( I0+1 ) )
+     $   GO TO 40
+*
+*     Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+      IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+     $    Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+     $   GO TO 30
+*
+   20 CONTINUE
+*
+      Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+      N0 = N0 - 1
+      GO TO 10
+*
+*     Check  whether E(N0-2) is negligible, 2 eigenvalues.
+*
+   30 CONTINUE
+*
+      IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+     $    Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+     $   GO TO 50
+*
+   40 CONTINUE
+*
+      IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+         S = Z( NN-3 )
+         Z( NN-3 ) = Z( NN-7 )
+         Z( NN-7 ) = S
+      END IF
+      IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+         T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+         S = Z( NN-3 )*( Z( NN-5 ) / T )
+         IF( S.LE.T ) THEN
+            S = Z( NN-3 )*( Z( NN-5 ) /
+     $          ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+         ELSE
+            S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+         END IF
+         T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+         Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+         Z( NN-7 ) = T
+      END IF
+      Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+      Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+      N0 = N0 - 2
+      GO TO 10
+*
+   50 CONTINUE
+*
+*     Reverse the qd-array, if warranted.
+*
+      IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+         IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+            IPN4 = 4*( I0+N0 )
+            DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+               TEMP = Z( J4-3 )
+               Z( J4-3 ) = Z( IPN4-J4-3 )
+               Z( IPN4-J4-3 ) = TEMP
+               TEMP = Z( J4-2 )
+               Z( J4-2 ) = Z( IPN4-J4-2 )
+               Z( IPN4-J4-2 ) = TEMP
+               TEMP = Z( J4-1 )
+               Z( J4-1 ) = Z( IPN4-J4-5 )
+               Z( IPN4-J4-5 ) = TEMP
+               TEMP = Z( J4 )
+               Z( J4 ) = Z( IPN4-J4-4 )
+               Z( IPN4-J4-4 ) = TEMP
+   60       CONTINUE
+            IF( N0-I0.LE.4 ) THEN
+               Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+               Z( 4*N0-PP ) = Z( 4*I0-PP )
+            END IF
+            DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+            Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+     $                            Z( 4*I0+PP+3 ) )
+            Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+     $                          Z( 4*I0-PP+4 ) )
+            QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+            DMIN = -ZERO
+         END IF
+      END IF
+*
+      IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+     $    Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+*        Choose a shift.
+*
+         CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+     $                DN2, TAU, TTYPE )
+*
+*        Call dqds until DMIN > 0.
+*
+   80    CONTINUE
+*
+         CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+     $                DN1, DN2, IEEE )
+*
+         NDIV = NDIV + ( N0-I0+2 )
+         ITER = ITER + 1
+*
+*        Check status.
+*
+         IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+*           Success.
+*
+            GO TO 100
+*
+         ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+     $            Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+     $            ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+*           Convergence hidden by negative DN.
+*
+            Z( 4*( N0-1 )-PP+2 ) = ZERO
+            DMIN = ZERO
+            GO TO 100
+         ELSE IF( DMIN.LT.ZERO ) THEN
+*
+*           TAU too big. Select new TAU and try again.
+*
+            NFAIL = NFAIL + 1
+            IF( TTYPE.LT.-22 ) THEN
+*
+*              Failed twice. Play it safe.
+*
+               TAU = ZERO
+            ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+*              Late failure. Gives excellent shift.
+*
+               TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+               TTYPE = TTYPE - 11
+            ELSE
+*
+*              Early failure. Divide by 4.
+*
+               TAU = QURTR*TAU
+               TTYPE = TTYPE - 12
+            END IF
+            GO TO 80
+         ELSE IF( DMIN.NE.DMIN ) THEN
+*
+*           NaN.
+*
+            TAU = ZERO
+            GO TO 80
+         ELSE
+*
+*           Possible underflow. Play it safe.
+*
+            GO TO 90
+         END IF
+      END IF
+*
+*     Risk of underflow.
+*
+   90 CONTINUE
+      CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+      NDIV = NDIV + ( N0-I0+2 )
+      ITER = ITER + 1
+      TAU = ZERO
+*
+  100 CONTINUE
+      IF( TAU.LT.SIGMA ) THEN
+         DESIG = DESIG + TAU
+         T = SIGMA + DESIG
+         DESIG = DESIG - ( T-SIGMA )
+      ELSE
+         T = SIGMA + TAU
+         DESIG = SIGMA - ( T-TAU ) + DESIG
+      END IF
+      SIGMA = T
+*
+      RETURN
+*
+*     End of DLASQ3
+*
+      END
diff --git a/src/lib/lapack/dlasq4.f b/src/lib/lapack/dlasq4.f
new file mode 100644
index 00000000..db2b6fe5
--- /dev/null
+++ b/src/lib/lapack/dlasq4.f
@@ -0,0 +1,329 @@
+      SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+     $                   DN1, DN2, TAU, TTYPE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I0, N0, N0IN, PP, TTYPE
+      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ4 computes an approximation TAU to the smallest eigenvalue 
+*  using values of d from the previous transform.
+*
+*  I0    (input) INTEGER
+*        First index.
+*
+*  N0    (input) INTEGER
+*        Last index.
+*
+*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
+*        Z holds the qd array.
+*
+*  PP    (input) INTEGER
+*        PP=0 for ping, PP=1 for pong.
+*
+*  N0IN  (input) INTEGER
+*        The value of N0 at start of EIGTEST.
+*
+*  DMIN  (input) DOUBLE PRECISION
+*        Minimum value of d.
+*
+*  DMIN1 (input) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (input) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (input) DOUBLE PRECISION
+*        d(N)
+*
+*  DN1   (input) DOUBLE PRECISION
+*        d(N-1)
+*
+*  DN2   (input) DOUBLE PRECISION
+*        d(N-2)
+*
+*  TAU   (output) DOUBLE PRECISION
+*        This is the shift.
+*
+*  TTYPE (output) INTEGER
+*        Shift type.
+*
+*  Further Details
+*  ===============
+*  CNST1 = 9/16
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   CNST1, CNST2, CNST3
+      PARAMETER          ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
+     $                   CNST3 = 1.050D0 )
+      DOUBLE PRECISION   QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+      PARAMETER          ( QURTR = 0.250D0, THIRD = 0.3330D0,
+     $                   HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
+     $                   TWO = 2.0D0, HUNDRD = 100.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I4, NN, NP
+      DOUBLE PRECISION   A2, B1, B2, G, GAM, GAP1, GAP2, S
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Save statement ..
+      SAVE               G
+*     ..
+*     .. Data statement ..
+      DATA               G / ZERO /
+*     ..
+*     .. Executable Statements ..
+*
+*     A negative DMIN forces the shift to take that absolute value
+*     TTYPE records the type of shift.
+*
+      IF( DMIN.LE.ZERO ) THEN
+         TAU = -DMIN
+         TTYPE = -1
+         RETURN
+      END IF
+*       
+      NN = 4*N0 + PP
+      IF( N0IN.EQ.N0 ) THEN
+*
+*        No eigenvalues deflated.
+*
+         IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+            B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+            B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+            A2 = Z( NN-7 ) + Z( NN-5 )
+*
+*           Cases 2 and 3.
+*
+            IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+               GAP2 = DMIN2 - A2 - DMIN2*QURTR
+               IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+                  GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+               ELSE
+                  GAP1 = A2 - DN - ( B1+B2 )
+               END IF
+               IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+                  S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+                  TTYPE = -2
+               ELSE
+                  S = ZERO
+                  IF( DN.GT.B1 )
+     $               S = DN - B1
+                  IF( A2.GT.( B1+B2 ) )
+     $               S = MIN( S, A2-( B1+B2 ) )
+                  S = MAX( S, THIRD*DMIN )
+                  TTYPE = -3
+               END IF
+            ELSE
+*
+*              Case 4.
+*
+               TTYPE = -4
+               S = QURTR*DMIN
+               IF( DMIN.EQ.DN ) THEN
+                  GAM = DN
+                  A2 = ZERO
+                  IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+     $               RETURN
+                  B2 = Z( NN-5 ) / Z( NN-7 )
+                  NP = NN - 9
+               ELSE
+                  NP = NN - 2*PP
+                  B2 = Z( NP-2 )
+                  GAM = DN1
+                  IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+     $               RETURN
+                  A2 = Z( NP-4 ) / Z( NP-2 )
+                  IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+     $               RETURN
+                  B2 = Z( NN-9 ) / Z( NN-11 )
+                  NP = NN - 13
+               END IF
+*
+*              Approximate contribution to norm squared from I < NN-1.
+*
+               A2 = A2 + B2
+               DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+                  IF( B2.EQ.ZERO )
+     $               GO TO 20
+                  B1 = B2
+                  IF( Z( I4 ) .GT. Z( I4-2 ) )
+     $               RETURN
+                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+                  A2 = A2 + B2
+                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 
+     $               GO TO 20
+   10          CONTINUE
+   20          CONTINUE
+               A2 = CNST3*A2
+*
+*              Rayleigh quotient residual bound.
+*
+               IF( A2.LT.CNST1 )
+     $            S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+            END IF
+         ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+*           Case 5.
+*
+            TTYPE = -5
+            S = QURTR*DMIN
+*
+*           Compute contribution to norm squared from I > NN-2.
+*
+            NP = NN - 2*PP
+            B1 = Z( NP-2 )
+            B2 = Z( NP-6 )
+            GAM = DN2
+            IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+     $         RETURN
+            A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+*           Approximate contribution to norm squared from I < NN-2.
+*
+            IF( N0-I0.GT.2 ) THEN
+               B2 = Z( NN-13 ) / Z( NN-15 )
+               A2 = A2 + B2
+               DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+                  IF( B2.EQ.ZERO )
+     $               GO TO 40
+                  B1 = B2
+                  IF( Z( I4 ) .GT. Z( I4-2 ) )
+     $               RETURN
+                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+                  A2 = A2 + B2
+                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 
+     $               GO TO 40
+   30          CONTINUE
+   40          CONTINUE
+               A2 = CNST3*A2
+            END IF
+*
+            IF( A2.LT.CNST1 )
+     $         S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+         ELSE
+*
+*           Case 6, no information to guide us.
+*
+            IF( TTYPE.EQ.-6 ) THEN
+               G = G + THIRD*( ONE-G )
+            ELSE IF( TTYPE.EQ.-18 ) THEN
+               G = QURTR*THIRD
+            ELSE
+               G = QURTR
+            END IF
+            S = G*DMIN
+            TTYPE = -6
+         END IF
+*
+      ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+*        One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+         IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN 
+*
+*           Cases 7 and 8.
+*
+            TTYPE = -7
+            S = THIRD*DMIN1
+            IF( Z( NN-5 ).GT.Z( NN-7 ) )
+     $         RETURN
+            B1 = Z( NN-5 ) / Z( NN-7 )
+            B2 = B1
+            IF( B2.EQ.ZERO )
+     $         GO TO 60
+            DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+               A2 = B1
+               IF( Z( I4 ).GT.Z( I4-2 ) )
+     $            RETURN
+               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+               B2 = B2 + B1
+               IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) 
+     $            GO TO 60
+   50       CONTINUE
+   60       CONTINUE
+            B2 = SQRT( CNST3*B2 )
+            A2 = DMIN1 / ( ONE+B2**2 )
+            GAP2 = HALF*DMIN2 - A2
+            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+            ELSE 
+               S = MAX( S, A2*( ONE-CNST2*B2 ) )
+               TTYPE = -8
+            END IF
+         ELSE
+*
+*           Case 9.
+*
+            S = QURTR*DMIN1
+            IF( DMIN1.EQ.DN1 )
+     $         S = HALF*DMIN1
+            TTYPE = -9
+         END IF
+*
+      ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+*        Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+*        Cases 10 and 11.
+*
+         IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN 
+            TTYPE = -10
+            S = THIRD*DMIN2
+            IF( Z( NN-5 ).GT.Z( NN-7 ) )
+     $         RETURN
+            B1 = Z( NN-5 ) / Z( NN-7 )
+            B2 = B1
+            IF( B2.EQ.ZERO )
+     $         GO TO 80
+            DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+               IF( Z( I4 ).GT.Z( I4-2 ) )
+     $            RETURN
+               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+               B2 = B2 + B1
+               IF( HUNDRD*B1.LT.B2 )
+     $            GO TO 80
+   70       CONTINUE
+   80       CONTINUE
+            B2 = SQRT( CNST3*B2 )
+            A2 = DMIN2 / ( ONE+B2**2 )
+            GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+     $             SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+            ELSE 
+               S = MAX( S, A2*( ONE-CNST2*B2 ) )
+            END IF
+         ELSE
+            S = QURTR*DMIN2
+            TTYPE = -11
+         END IF
+      ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+*        Case 12, more than two eigenvalues deflated. No information.
+*
+         S = ZERO 
+         TTYPE = -12
+      END IF
+*
+      TAU = S
+      RETURN
+*
+*     End of DLASQ4
+*
+      END
diff --git a/src/lib/lapack/dlasq5.f b/src/lib/lapack/dlasq5.f
new file mode 100644
index 00000000..a006c99e
--- /dev/null
+++ b/src/lib/lapack/dlasq5.f
@@ -0,0 +1,195 @@
+      SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+     $                   DNM1, DNM2, IEEE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            I0, N0, PP
+      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ5 computes one dqds transform in ping-pong form, one
+*  version for IEEE machines another for non IEEE machines.
+*
+*  Arguments
+*  =========
+*
+*  I0    (input) INTEGER
+*        First index.
+*
+*  N0    (input) INTEGER
+*        Last index.
+*
+*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
+*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+*        an extra argument.
+*
+*  PP    (input) INTEGER
+*        PP=0 for ping, PP=1 for pong.
+*
+*  TAU   (input) DOUBLE PRECISION
+*        This is the shift.
+*
+*  DMIN  (output) DOUBLE PRECISION
+*        Minimum value of d.
+*
+*  DMIN1 (output) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (output) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (output) DOUBLE PRECISION
+*        d(N0), the last value of d.
+*
+*  DNM1  (output) DOUBLE PRECISION
+*        d(N0-1).
+*
+*  DNM2  (output) DOUBLE PRECISION
+*        d(N0-2).
+*
+*  IEEE  (input) LOGICAL
+*        Flag for IEEE or non IEEE arithmetic.
+*
+*  =====================================================================
+*
+*     .. Parameter ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J4, J4P2
+      DOUBLE PRECISION   D, EMIN, TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ( N0-I0-1 ).LE.0 )
+     $   RETURN
+*
+      J4 = 4*I0 + PP - 3
+      EMIN = Z( J4+4 )
+      D = Z( J4 ) - TAU
+      DMIN = D
+      DMIN1 = -Z( J4 )
+*
+      IF( IEEE ) THEN
+*
+*        Code for IEEE arithmetic.
+*
+         IF( PP.EQ.0 ) THEN
+            DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+               Z( J4-2 ) = D + Z( J4-1 )
+               TEMP = Z( J4+1 ) / Z( J4-2 )
+               D = D*TEMP - TAU
+               DMIN = MIN( DMIN, D )
+               Z( J4 ) = Z( J4-1 )*TEMP
+               EMIN = MIN( Z( J4 ), EMIN )
+   10       CONTINUE
+         ELSE
+            DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+               Z( J4-3 ) = D + Z( J4 )
+               TEMP = Z( J4+2 ) / Z( J4-3 )
+               D = D*TEMP - TAU
+               DMIN = MIN( DMIN, D )
+               Z( J4-1 ) = Z( J4 )*TEMP
+               EMIN = MIN( Z( J4-1 ), EMIN )
+   20       CONTINUE
+         END IF
+*
+*        Unroll last two steps.
+*
+         DNM2 = D
+         DMIN2 = DMIN
+         J4 = 4*( N0-2 ) - PP
+         J4P2 = J4 + 2*PP - 1
+         Z( J4-2 ) = DNM2 + Z( J4P2 )
+         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+         DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+         DMIN = MIN( DMIN, DNM1 )
+*
+         DMIN1 = DMIN
+         J4 = J4 + 4
+         J4P2 = J4 + 2*PP - 1
+         Z( J4-2 ) = DNM1 + Z( J4P2 )
+         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+         DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+         DMIN = MIN( DMIN, DN )
+*
+      ELSE
+*
+*        Code for non IEEE arithmetic.
+*
+         IF( PP.EQ.0 ) THEN
+            DO 30 J4 = 4*I0, 4*( N0-3 ), 4
+               Z( J4-2 ) = D + Z( J4-1 )
+               IF( D.LT.ZERO ) THEN
+                  RETURN
+               ELSE
+                  Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+                  D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
+               END IF
+               DMIN = MIN( DMIN, D )
+               EMIN = MIN( EMIN, Z( J4 ) )
+   30       CONTINUE
+         ELSE
+            DO 40 J4 = 4*I0, 4*( N0-3 ), 4
+               Z( J4-3 ) = D + Z( J4 )
+               IF( D.LT.ZERO ) THEN
+                  RETURN
+               ELSE
+                  Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+                  D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
+               END IF
+               DMIN = MIN( DMIN, D )
+               EMIN = MIN( EMIN, Z( J4-1 ) )
+   40       CONTINUE
+         END IF
+*
+*        Unroll last two steps.
+*
+         DNM2 = D
+         DMIN2 = DMIN
+         J4 = 4*( N0-2 ) - PP
+         J4P2 = J4 + 2*PP - 1
+         Z( J4-2 ) = DNM2 + Z( J4P2 )
+         IF( DNM2.LT.ZERO ) THEN
+            RETURN
+         ELSE
+            Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+            DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+         END IF
+         DMIN = MIN( DMIN, DNM1 )
+*
+         DMIN1 = DMIN
+         J4 = J4 + 4
+         J4P2 = J4 + 2*PP - 1
+         Z( J4-2 ) = DNM1 + Z( J4P2 )
+         IF( DNM1.LT.ZERO ) THEN
+            RETURN
+         ELSE
+            Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+            DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+         END IF
+         DMIN = MIN( DMIN, DN )
+*
+      END IF
+*
+      Z( J4+2 ) = DN
+      Z( 4*N0-PP ) = EMIN
+      RETURN
+*
+*     End of DLASQ5
+*
+      END
diff --git a/src/lib/lapack/dlasq6.f b/src/lib/lapack/dlasq6.f
new file mode 100644
index 00000000..e7eb7d0a
--- /dev/null
+++ b/src/lib/lapack/dlasq6.f
@@ -0,0 +1,175 @@
+      SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
+     $                   DNM1, DNM2 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I0, N0, PP
+      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASQ6 computes one dqd (shift equal to zero) transform in
+*  ping-pong form, with protection against underflow and overflow.
+*
+*  Arguments
+*  =========
+*
+*  I0    (input) INTEGER
+*        First index.
+*
+*  N0    (input) INTEGER
+*        Last index.
+*
+*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
+*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+*        an extra argument.
+*
+*  PP    (input) INTEGER
+*        PP=0 for ping, PP=1 for pong.
+*
+*  DMIN  (output) DOUBLE PRECISION
+*        Minimum value of d.
+*
+*  DMIN1 (output) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (output) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (output) DOUBLE PRECISION
+*        d(N0), the last value of d.
+*
+*  DNM1  (output) DOUBLE PRECISION
+*        d(N0-1).
+*
+*  DNM2  (output) DOUBLE PRECISION
+*        d(N0-2).
+*
+*  =====================================================================
+*
+*     .. Parameter ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J4, J4P2
+      DOUBLE PRECISION   D, EMIN, SAFMIN, TEMP
+*     ..
+*     .. External Function ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ( N0-I0-1 ).LE.0 )
+     $   RETURN
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      J4 = 4*I0 + PP - 3
+      EMIN = Z( J4+4 ) 
+      D = Z( J4 )
+      DMIN = D
+*
+      IF( PP.EQ.0 ) THEN
+         DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+            Z( J4-2 ) = D + Z( J4-1 ) 
+            IF( Z( J4-2 ).EQ.ZERO ) THEN
+               Z( J4 ) = ZERO
+               D = Z( J4+1 )
+               DMIN = D
+               EMIN = ZERO
+            ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
+     $               SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
+               TEMP = Z( J4+1 ) / Z( J4-2 )
+               Z( J4 ) = Z( J4-1 )*TEMP
+               D = D*TEMP
+            ELSE 
+               Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+               D = Z( J4+1 )*( D / Z( J4-2 ) )
+            END IF
+            DMIN = MIN( DMIN, D )
+            EMIN = MIN( EMIN, Z( J4 ) )
+   10    CONTINUE
+      ELSE
+         DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+            Z( J4-3 ) = D + Z( J4 ) 
+            IF( Z( J4-3 ).EQ.ZERO ) THEN
+               Z( J4-1 ) = ZERO
+               D = Z( J4+2 )
+               DMIN = D
+               EMIN = ZERO
+            ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
+     $               SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
+               TEMP = Z( J4+2 ) / Z( J4-3 )
+               Z( J4-1 ) = Z( J4 )*TEMP
+               D = D*TEMP
+            ELSE 
+               Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+               D = Z( J4+2 )*( D / Z( J4-3 ) )
+            END IF
+            DMIN = MIN( DMIN, D )
+            EMIN = MIN( EMIN, Z( J4-1 ) )
+   20    CONTINUE
+      END IF
+*
+*     Unroll last two steps. 
+*
+      DNM2 = D
+      DMIN2 = DMIN
+      J4 = 4*( N0-2 ) - PP
+      J4P2 = J4 + 2*PP - 1
+      Z( J4-2 ) = DNM2 + Z( J4P2 )
+      IF( Z( J4-2 ).EQ.ZERO ) THEN
+         Z( J4 ) = ZERO
+         DNM1 = Z( J4P2+2 )
+         DMIN = DNM1
+         EMIN = ZERO
+      ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+     $         SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+         TEMP = Z( J4P2+2 ) / Z( J4-2 )
+         Z( J4 ) = Z( J4P2 )*TEMP
+         DNM1 = DNM2*TEMP
+      ELSE
+         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+         DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
+      END IF
+      DMIN = MIN( DMIN, DNM1 )
+*
+      DMIN1 = DMIN
+      J4 = J4 + 4
+      J4P2 = J4 + 2*PP - 1
+      Z( J4-2 ) = DNM1 + Z( J4P2 )
+      IF( Z( J4-2 ).EQ.ZERO ) THEN
+         Z( J4 ) = ZERO
+         DN = Z( J4P2+2 )
+         DMIN = DN
+         EMIN = ZERO
+      ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+     $         SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+         TEMP = Z( J4P2+2 ) / Z( J4-2 )
+         Z( J4 ) = Z( J4P2 )*TEMP
+         DN = DNM1*TEMP
+      ELSE
+         Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+         DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
+      END IF
+      DMIN = MIN( DMIN, DN )
+*
+      Z( J4+2 ) = DN
+      Z( 4*N0-PP ) = EMIN
+      RETURN
+*
+*     End of DLASQ6
+*
+      END
diff --git a/src/lib/lapack/dlasr.f b/src/lib/lapack/dlasr.f
new file mode 100644
index 00000000..7e54bfc7
--- /dev/null
+++ b/src/lib/lapack/dlasr.f
@@ -0,0 +1,361 @@
+      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, PIVOT, SIDE
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASR applies a sequence of plane rotations to a real matrix A,
+*  from either the left or the right.
+*  
+*  When SIDE = 'L', the transformation takes the form
+*  
+*     A := P*A
+*  
+*  and when SIDE = 'R', the transformation takes the form
+*  
+*     A := A*P**T
+*  
+*  where P is an orthogonal matrix consisting of a sequence of z plane
+*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
+*  and P**T is the transpose of P.
+*  
+*  When DIRECT = 'F' (Forward sequence), then
+*  
+*     P = P(z-1) * ... * P(2) * P(1)
+*  
+*  and when DIRECT = 'B' (Backward sequence), then
+*  
+*     P = P(1) * P(2) * ... * P(z-1)
+*  
+*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
+*  
+*     R(k) = (  c(k)  s(k) )
+*          = ( -s(k)  c(k) ).
+*  
+*  When PIVOT = 'V' (Variable pivot), the rotation is performed
+*  for the plane (k,k+1), i.e., P(k) has the form
+*  
+*     P(k) = (  1                                            )
+*            (       ...                                     )
+*            (              1                                )
+*            (                   c(k)  s(k)                  )
+*            (                  -s(k)  c(k)                  )
+*            (                                1              )
+*            (                                     ...       )
+*            (                                            1  )
+*  
+*  where R(k) appears as a rank-2 modification to the identity matrix in
+*  rows and columns k and k+1.
+*  
+*  When PIVOT = 'T' (Top pivot), the rotation is performed for the
+*  plane (1,k+1), so P(k) has the form
+*  
+*     P(k) = (  c(k)                    s(k)                 )
+*            (         1                                     )
+*            (              ...                              )
+*            (                     1                         )
+*            ( -s(k)                    c(k)                 )
+*            (                                 1             )
+*            (                                      ...      )
+*            (                                             1 )
+*  
+*  where R(k) appears in rows and columns 1 and k+1.
+*  
+*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
+*  performed for the plane (k,z), giving P(k) the form
+*  
+*     P(k) = ( 1                                             )
+*            (      ...                                      )
+*            (             1                                 )
+*            (                  c(k)                    s(k) )
+*            (                         1                     )
+*            (                              ...              )
+*            (                                     1         )
+*            (                 -s(k)                    c(k) )
+*  
+*  where R(k) appears in rows and columns k and z.  The rotations are
+*  performed without ever forming P(k) explicitly.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          Specifies whether the plane rotation matrix P is applied to
+*          A on the left or the right.
+*          = 'L':  Left, compute A := P*A
+*          = 'R':  Right, compute A:= A*P**T
+*
+*  PIVOT   (input) CHARACTER*1
+*          Specifies the plane for which P(k) is a plane rotation
+*          matrix.
+*          = 'V':  Variable pivot, the plane (k,k+1)
+*          = 'T':  Top pivot, the plane (1,k+1)
+*          = 'B':  Bottom pivot, the plane (k,z)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies whether P is a forward or backward sequence of
+*          plane rotations.
+*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)
+*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  If m <= 1, an immediate
+*          return is effected.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  If n <= 1, an
+*          immediate return is effected.
+*
+*  C       (input) DOUBLE PRECISION array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The cosines c(k) of the plane rotations.
+*
+*  S       (input) DOUBLE PRECISION array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The sines s(k) of the plane rotations.  The 2-by-2 plane
+*          rotation part of the matrix P(k), R(k), has the form
+*          R(k) = (  c(k)  s(k) )
+*                 ( -s(k)  c(k) ).
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          The M-by-N matrix A.  On exit, A is overwritten by P*A if
+*          SIDE = 'R' or by A*P**T if SIDE = 'L'.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+      DOUBLE PRECISION   CTEMP, STEMP, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
+         INFO = 1
+      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
+     $         'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
+         INFO = 2
+      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
+     $          THEN
+         INFO = 3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = 4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASR ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  P * A
+*
+         IF( LSAME( PIVOT, 'V' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 20 J = 1, M - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 10 I = 1, N
+                        TEMP = A( J+1, I )
+                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+   10                CONTINUE
+                  END IF
+   20          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 40 J = M - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 30 I = 1, N
+                        TEMP = A( J+1, I )
+                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+   30                CONTINUE
+                  END IF
+   40          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 60 J = 2, M
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 50 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+   50                CONTINUE
+                  END IF
+   60          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 80 J = M, 2, -1
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 70 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+   70                CONTINUE
+                  END IF
+   80          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 100 J = 1, M - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 90 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+   90                CONTINUE
+                  END IF
+  100          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 120 J = M - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 110 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+  110                CONTINUE
+                  END IF
+  120          CONTINUE
+            END IF
+         END IF
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        Form A * P'
+*
+         IF( LSAME( PIVOT, 'V' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 140 J = 1, N - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 130 I = 1, M
+                        TEMP = A( I, J+1 )
+                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+  130                CONTINUE
+                  END IF
+  140          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 160 J = N - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 150 I = 1, M
+                        TEMP = A( I, J+1 )
+                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+  150                CONTINUE
+                  END IF
+  160          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 180 J = 2, N
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 170 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+  170                CONTINUE
+                  END IF
+  180          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 200 J = N, 2, -1
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 190 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+  190                CONTINUE
+                  END IF
+  200          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 220 J = 1, N - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 210 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+  210                CONTINUE
+                  END IF
+  220          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 240 J = N - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 230 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+  230                CONTINUE
+                  END IF
+  240          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DLASR
+*
+      END
diff --git a/src/lib/lapack/dlasrt.f b/src/lib/lapack/dlasrt.f
new file mode 100644
index 00000000..37e02178
--- /dev/null
+++ b/src/lib/lapack/dlasrt.f
@@ -0,0 +1,243 @@
+      SUBROUTINE DLASRT( ID, N, D, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          ID
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Sort the numbers in D in increasing order (if ID = 'I') or
+*  in decreasing order (if ID = 'D' ).
+*
+*  Use Quick Sort, reverting to Insertion sort on arrays of
+*  size <= 20. Dimension of STACK limits N to about 2**32.
+*
+*  Arguments
+*  =========
+*
+*  ID      (input) CHARACTER*1
+*          = 'I': sort D in increasing order;
+*          = 'D': sort D in decreasing order.
+*
+*  N       (input) INTEGER
+*          The length of the array D.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the array to be sorted.
+*          On exit, D has been sorted into increasing order
+*          (D(1) <= ... <= D(N) ) or into decreasing order
+*          (D(1) >= ... >= D(N) ), depending on ID.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            SELECT
+      PARAMETER          ( SELECT = 20 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            DIR, ENDD, I, J, START, STKPNT
+      DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
+*     ..
+*     .. Local Arrays ..
+      INTEGER            STACK( 2, 32 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input paramters.
+*
+      INFO = 0
+      DIR = -1
+      IF( LSAME( ID, 'D' ) ) THEN
+         DIR = 0
+      ELSE IF( LSAME( ID, 'I' ) ) THEN
+         DIR = 1
+      END IF
+      IF( DIR.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLASRT', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      STKPNT = 1
+      STACK( 1, 1 ) = 1
+      STACK( 2, 1 ) = N
+   10 CONTINUE
+      START = STACK( 1, STKPNT )
+      ENDD = STACK( 2, STKPNT )
+      STKPNT = STKPNT - 1
+      IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
+*
+*        Do Insertion sort on D( START:ENDD )
+*
+         IF( DIR.EQ.0 ) THEN
+*
+*           Sort into decreasing order
+*
+            DO 30 I = START + 1, ENDD
+               DO 20 J = I, START + 1, -1
+                  IF( D( J ).GT.D( J-1 ) ) THEN
+                     DMNMX = D( J )
+                     D( J ) = D( J-1 )
+                     D( J-1 ) = DMNMX
+                  ELSE
+                     GO TO 30
+                  END IF
+   20          CONTINUE
+   30       CONTINUE
+*
+         ELSE
+*
+*           Sort into increasing order
+*
+            DO 50 I = START + 1, ENDD
+               DO 40 J = I, START + 1, -1
+                  IF( D( J ).LT.D( J-1 ) ) THEN
+                     DMNMX = D( J )
+                     D( J ) = D( J-1 )
+                     D( J-1 ) = DMNMX
+                  ELSE
+                     GO TO 50
+                  END IF
+   40          CONTINUE
+   50       CONTINUE
+*
+         END IF
+*
+      ELSE IF( ENDD-START.GT.SELECT ) THEN
+*
+*        Partition D( START:ENDD ) and stack parts, largest one first
+*
+*        Choose partition entry as median of 3
+*
+         D1 = D( START )
+         D2 = D( ENDD )
+         I = ( START+ENDD ) / 2
+         D3 = D( I )
+         IF( D1.LT.D2 ) THEN
+            IF( D3.LT.D1 ) THEN
+               DMNMX = D1
+            ELSE IF( D3.LT.D2 ) THEN
+               DMNMX = D3
+            ELSE
+               DMNMX = D2
+            END IF
+         ELSE
+            IF( D3.LT.D2 ) THEN
+               DMNMX = D2
+            ELSE IF( D3.LT.D1 ) THEN
+               DMNMX = D3
+            ELSE
+               DMNMX = D1
+            END IF
+         END IF
+*
+         IF( DIR.EQ.0 ) THEN
+*
+*           Sort into decreasing order
+*
+            I = START - 1
+            J = ENDD + 1
+   60       CONTINUE
+   70       CONTINUE
+            J = J - 1
+            IF( D( J ).LT.DMNMX )
+     $         GO TO 70
+   80       CONTINUE
+            I = I + 1
+            IF( D( I ).GT.DMNMX )
+     $         GO TO 80
+            IF( I.LT.J ) THEN
+               TMP = D( I )
+               D( I ) = D( J )
+               D( J ) = TMP
+               GO TO 60
+            END IF
+            IF( J-START.GT.ENDD-J-1 ) THEN
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = START
+               STACK( 2, STKPNT ) = J
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = J + 1
+               STACK( 2, STKPNT ) = ENDD
+            ELSE
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = J + 1
+               STACK( 2, STKPNT ) = ENDD
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = START
+               STACK( 2, STKPNT ) = J
+            END IF
+         ELSE
+*
+*           Sort into increasing order
+*
+            I = START - 1
+            J = ENDD + 1
+   90       CONTINUE
+  100       CONTINUE
+            J = J - 1
+            IF( D( J ).GT.DMNMX )
+     $         GO TO 100
+  110       CONTINUE
+            I = I + 1
+            IF( D( I ).LT.DMNMX )
+     $         GO TO 110
+            IF( I.LT.J ) THEN
+               TMP = D( I )
+               D( I ) = D( J )
+               D( J ) = TMP
+               GO TO 90
+            END IF
+            IF( J-START.GT.ENDD-J-1 ) THEN
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = START
+               STACK( 2, STKPNT ) = J
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = J + 1
+               STACK( 2, STKPNT ) = ENDD
+            ELSE
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = J + 1
+               STACK( 2, STKPNT ) = ENDD
+               STKPNT = STKPNT + 1
+               STACK( 1, STKPNT ) = START
+               STACK( 2, STKPNT ) = J
+            END IF
+         END IF
+      END IF
+      IF( STKPNT.GT.0 )
+     $   GO TO 10
+      RETURN
+*
+*     End of DLASRT
+*
+      END
diff --git a/src/lib/lapack/dlassq.f b/src/lib/lapack/dlassq.f
new file mode 100644
index 00000000..217e794d
--- /dev/null
+++ b/src/lib/lapack/dlassq.f
@@ -0,0 +1,88 @@
+      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   SCALE, SUMSQ
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASSQ  returns the values  scl  and  smsq  such that
+*
+*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
+*
+*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is
+*  assumed to be non-negative and  scl  returns the value
+*
+*     scl = max( scale, abs( x( i ) ) ).
+*
+*  scale and sumsq must be supplied in SCALE and SUMSQ and
+*  scl and smsq are overwritten on SCALE and SUMSQ respectively.
+*
+*  The routine makes only one pass through the vector x.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements to be used from the vector X.
+*
+*  X       (input) DOUBLE PRECISION array, dimension (N)
+*          The vector for which a scaled sum of squares is computed.
+*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of the vector X.
+*          INCX > 0.
+*
+*  SCALE   (input/output) DOUBLE PRECISION
+*          On entry, the value  scale  in the equation above.
+*          On exit, SCALE is overwritten with  scl , the scaling factor
+*          for the sum of squares.
+*
+*  SUMSQ   (input/output) DOUBLE PRECISION
+*          On entry, the value  sumsq  in the equation above.
+*          On exit, SUMSQ is overwritten with  smsq , the basic sum of
+*          squares from which  scl  has been factored out.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IX
+      DOUBLE PRECISION   ABSXI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.GT.0 ) THEN
+         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
+            IF( X( IX ).NE.ZERO ) THEN
+               ABSXI = ABS( X( IX ) )
+               IF( SCALE.LT.ABSXI ) THEN
+                  SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
+                  SCALE = ABSXI
+               ELSE
+                  SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
+               END IF
+            END IF
+   10    CONTINUE
+      END IF
+      RETURN
+*
+*     End of DLASSQ
+*
+      END
diff --git a/src/lib/lapack/dlasv2.f b/src/lib/lapack/dlasv2.f
new file mode 100644
index 00000000..4a00b25d
--- /dev/null
+++ b/src/lib/lapack/dlasv2.f
@@ -0,0 +1,249 @@
+      SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASV2 computes the singular value decomposition of a 2-by-2
+*  triangular matrix
+*     [  F   G  ]
+*     [  0   H  ].
+*  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
+*  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
+*  right singular vectors for abs(SSMAX), giving the decomposition
+*
+*     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
+*     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
+*
+*  Arguments
+*  =========
+*
+*  F       (input) DOUBLE PRECISION
+*          The (1,1) element of the 2-by-2 matrix.
+*
+*  G       (input) DOUBLE PRECISION
+*          The (1,2) element of the 2-by-2 matrix.
+*
+*  H       (input) DOUBLE PRECISION
+*          The (2,2) element of the 2-by-2 matrix.
+*
+*  SSMIN   (output) DOUBLE PRECISION
+*          abs(SSMIN) is the smaller singular value.
+*
+*  SSMAX   (output) DOUBLE PRECISION
+*          abs(SSMAX) is the larger singular value.
+*
+*  SNL     (output) DOUBLE PRECISION
+*  CSL     (output) DOUBLE PRECISION
+*          The vector (CSL, SNL) is a unit left singular vector for the
+*          singular value abs(SSMAX).
+*
+*  SNR     (output) DOUBLE PRECISION
+*  CSR     (output) DOUBLE PRECISION
+*          The vector (CSR, SNR) is a unit right singular vector for the
+*          singular value abs(SSMAX).
+*
+*  Further Details
+*  ===============
+*
+*  Any input parameter may be aliased with any output parameter.
+*
+*  Barring over/underflow and assuming a guard digit in subtraction, all
+*  output quantities are correct to within a few units in the last
+*  place (ulps).
+*
+*  In IEEE arithmetic, the code works correctly if one matrix element is
+*  infinite.
+*
+*  Overflow will not occur unless the largest singular value itself
+*  overflows or is within a few ulps of overflow. (On machines with
+*  partial overflow, like the Cray, overflow may occur if the largest
+*  singular value is within a factor of 2 of overflow.)
+*
+*  Underflow is harmless if underflow is gradual. Otherwise, results
+*  may correspond to a matrix modified by perturbations of size near
+*  the underflow threshold.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = 0.5D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0D0 )
+      DOUBLE PRECISION   FOUR
+      PARAMETER          ( FOUR = 4.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            GASMAL, SWAP
+      INTEGER            PMAX
+      DOUBLE PRECISION   A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
+     $                   MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+      FT = F
+      FA = ABS( FT )
+      HT = H
+      HA = ABS( H )
+*
+*     PMAX points to the maximum absolute element of matrix
+*       PMAX = 1 if F largest in absolute values
+*       PMAX = 2 if G largest in absolute values
+*       PMAX = 3 if H largest in absolute values
+*
+      PMAX = 1
+      SWAP = ( HA.GT.FA )
+      IF( SWAP ) THEN
+         PMAX = 3
+         TEMP = FT
+         FT = HT
+         HT = TEMP
+         TEMP = FA
+         FA = HA
+         HA = TEMP
+*
+*        Now FA .ge. HA
+*
+      END IF
+      GT = G
+      GA = ABS( GT )
+      IF( GA.EQ.ZERO ) THEN
+*
+*        Diagonal matrix
+*
+         SSMIN = HA
+         SSMAX = FA
+         CLT = ONE
+         CRT = ONE
+         SLT = ZERO
+         SRT = ZERO
+      ELSE
+         GASMAL = .TRUE.
+         IF( GA.GT.FA ) THEN
+            PMAX = 2
+            IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
+*
+*              Case of very large GA
+*
+               GASMAL = .FALSE.
+               SSMAX = GA
+               IF( HA.GT.ONE ) THEN
+                  SSMIN = FA / ( GA / HA )
+               ELSE
+                  SSMIN = ( FA / GA )*HA
+               END IF
+               CLT = ONE
+               SLT = HT / GT
+               SRT = ONE
+               CRT = FT / GT
+            END IF
+         END IF
+         IF( GASMAL ) THEN
+*
+*           Normal case
+*
+            D = FA - HA
+            IF( D.EQ.FA ) THEN
+*
+*              Copes with infinite F or H
+*
+               L = ONE
+            ELSE
+               L = D / FA
+            END IF
+*
+*           Note that 0 .le. L .le. 1
+*
+            M = GT / FT
+*
+*           Note that abs(M) .le. 1/macheps
+*
+            T = TWO - L
+*
+*           Note that T .ge. 1
+*
+            MM = M*M
+            TT = T*T
+            S = SQRT( TT+MM )
+*
+*           Note that 1 .le. S .le. 1 + 1/macheps
+*
+            IF( L.EQ.ZERO ) THEN
+               R = ABS( M )
+            ELSE
+               R = SQRT( L*L+MM )
+            END IF
+*
+*           Note that 0 .le. R .le. 1 + 1/macheps
+*
+            A = HALF*( S+R )
+*
+*           Note that 1 .le. A .le. 1 + abs(M)
+*
+            SSMIN = HA / A
+            SSMAX = FA*A
+            IF( MM.EQ.ZERO ) THEN
+*
+*              Note that M is very tiny
+*
+               IF( L.EQ.ZERO ) THEN
+                  T = SIGN( TWO, FT )*SIGN( ONE, GT )
+               ELSE
+                  T = GT / SIGN( D, FT ) + M / T
+               END IF
+            ELSE
+               T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
+            END IF
+            L = SQRT( T*T+FOUR )
+            CRT = TWO / L
+            SRT = T / L
+            CLT = ( CRT+SRT*M ) / A
+            SLT = ( HT / FT )*SRT / A
+         END IF
+      END IF
+      IF( SWAP ) THEN
+         CSL = SRT
+         SNL = CRT
+         CSR = SLT
+         SNR = CLT
+      ELSE
+         CSL = CLT
+         SNL = SLT
+         CSR = CRT
+         SNR = SRT
+      END IF
+*
+*     Correct signs of SSMAX and SSMIN
+*
+      IF( PMAX.EQ.1 )
+     $   TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
+      IF( PMAX.EQ.2 )
+     $   TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
+      IF( PMAX.EQ.3 )
+     $   TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
+      SSMAX = SIGN( SSMAX, TSIGN )
+      SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
+      RETURN
+*
+*     End of DLASV2
+*
+      END
diff --git a/src/lib/lapack/dlaswp.f b/src/lib/lapack/dlaswp.f
new file mode 100644
index 00000000..a11a87e9
--- /dev/null
+++ b/src/lib/lapack/dlaswp.f
@@ -0,0 +1,119 @@
+      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, K1, K2, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASWP performs a series of row interchanges on the matrix A.
+*  One row interchange is initiated for each of rows K1 through K2 of A.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the matrix of column dimension N to which the row
+*          interchanges will be applied.
+*          On exit, the permuted matrix.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*
+*  K1      (input) INTEGER
+*          The first element of IPIV for which a row interchange will
+*          be done.
+*
+*  K2      (input) INTEGER
+*          The last element of IPIV for which a row interchange will
+*          be done.
+*
+*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))
+*          The vector of pivot indices.  Only the elements in positions
+*          K1 through K2 of IPIV are accessed.
+*          IPIV(K) = L implies rows K and L are to be interchanged.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of IPIV.  If IPIV
+*          is negative, the pivots are applied in reverse order.
+*
+*  Further Details
+*  ===============
+*
+*  Modified by
+*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
+      DOUBLE PRECISION   TEMP
+*     ..
+*     .. Executable Statements ..
+*
+*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+      IF( INCX.GT.0 ) THEN
+         IX0 = K1
+         I1 = K1
+         I2 = K2
+         INC = 1
+      ELSE IF( INCX.LT.0 ) THEN
+         IX0 = 1 + ( 1-K2 )*INCX
+         I1 = K2
+         I2 = K1
+         INC = -1
+      ELSE
+         RETURN
+      END IF
+*
+      N32 = ( N / 32 )*32
+      IF( N32.NE.0 ) THEN
+         DO 30 J = 1, N32, 32
+            IX = IX0
+            DO 20 I = I1, I2, INC
+               IP = IPIV( IX )
+               IF( IP.NE.I ) THEN
+                  DO 10 K = J, J + 31
+                     TEMP = A( I, K )
+                     A( I, K ) = A( IP, K )
+                     A( IP, K ) = TEMP
+   10             CONTINUE
+               END IF
+               IX = IX + INCX
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+      IF( N32.NE.N ) THEN
+         N32 = N32 + 1
+         IX = IX0
+         DO 50 I = I1, I2, INC
+            IP = IPIV( IX )
+            IF( IP.NE.I ) THEN
+               DO 40 K = N32, N
+                  TEMP = A( I, K )
+                  A( I, K ) = A( IP, K )
+                  A( IP, K ) = TEMP
+   40          CONTINUE
+            END IF
+            IX = IX + INCX
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLASWP
+*
+      END
diff --git a/src/lib/lapack/dlasy2.f b/src/lib/lapack/dlasy2.f
new file mode 100644
index 00000000..3ff12070
--- /dev/null
+++ b/src/lib/lapack/dlasy2.f
@@ -0,0 +1,381 @@
+      SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
+     $                   LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            LTRANL, LTRANR
+      INTEGER            INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
+      DOUBLE PRECISION   SCALE, XNORM
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
+     $                   X( LDX, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
+*
+*         op(TL)*X + ISGN*X*op(TR) = SCALE*B,
+*
+*  where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
+*  -1.  op(T) = T or T', where T' denotes the transpose of T.
+*
+*  Arguments
+*  =========
+*
+*  LTRANL  (input) LOGICAL
+*          On entry, LTRANL specifies the op(TL):
+*             = .FALSE., op(TL) = TL,
+*             = .TRUE., op(TL) = TL'.
+*
+*  LTRANR  (input) LOGICAL
+*          On entry, LTRANR specifies the op(TR):
+*            = .FALSE., op(TR) = TR,
+*            = .TRUE., op(TR) = TR'.
+*
+*  ISGN    (input) INTEGER
+*          On entry, ISGN specifies the sign of the equation
+*          as described before. ISGN may only be 1 or -1.
+*
+*  N1      (input) INTEGER
+*          On entry, N1 specifies the order of matrix TL.
+*          N1 may only be 0, 1 or 2.
+*
+*  N2      (input) INTEGER
+*          On entry, N2 specifies the order of matrix TR.
+*          N2 may only be 0, 1 or 2.
+*
+*  TL      (input) DOUBLE PRECISION array, dimension (LDTL,2)
+*          On entry, TL contains an N1 by N1 matrix.
+*
+*  LDTL    (input) INTEGER
+*          The leading dimension of the matrix TL. LDTL >= max(1,N1).
+*
+*  TR      (input) DOUBLE PRECISION array, dimension (LDTR,2)
+*          On entry, TR contains an N2 by N2 matrix.
+*
+*  LDTR    (input) INTEGER
+*          The leading dimension of the matrix TR. LDTR >= max(1,N2).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,2)
+*          On entry, the N1 by N2 matrix B contains the right-hand
+*          side of the equation.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the matrix B. LDB >= max(1,N1).
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit, SCALE contains the scale factor. SCALE is chosen
+*          less than or equal to 1 to prevent the solution overflowing.
+*
+*  X       (output) DOUBLE PRECISION array, dimension (LDX,2)
+*          On exit, X contains the N1 by N2 solution.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the matrix X. LDX >= max(1,N1).
+*
+*  XNORM   (output) DOUBLE PRECISION
+*          On exit, XNORM is the infinity-norm of the solution.
+*
+*  INFO    (output) INTEGER
+*          On exit, INFO is set to
+*             0: successful exit.
+*             1: TL and TR have too close eigenvalues, so TL or
+*                TR is perturbed to get a nonsingular equation.
+*          NOTE: In the interests of speed, this routine does not
+*                check the inputs for errors.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   TWO, HALF, EIGHT
+      PARAMETER          ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            BSWAP, XSWAP
+      INTEGER            I, IP, IPIV, IPSV, J, JP, JPSV, K
+      DOUBLE PRECISION   BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
+     $                   TEMP, U11, U12, U22, XMAX
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            BSWPIV( 4 ), XSWPIV( 4 )
+      INTEGER            JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
+     $                   LOCU22( 4 )
+      DOUBLE PRECISION   BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           IDAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Data statements ..
+      DATA               LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
+     $                   LOCU22 / 4, 3, 2, 1 /
+      DATA               XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
+      DATA               BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+*     Do not check the input parameters for errors
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N1.EQ.0 .OR. N2.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      SGN = ISGN
+*
+      K = N1 + N1 + N2 - 2
+      GO TO ( 10, 20, 30, 50 )K
+*
+*     1 by 1: TL11*X + SGN*X*TR11 = B11
+*
+   10 CONTINUE
+      TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
+      BET = ABS( TAU1 )
+      IF( BET.LE.SMLNUM ) THEN
+         TAU1 = SMLNUM
+         BET = SMLNUM
+         INFO = 1
+      END IF
+*
+      SCALE = ONE
+      GAM = ABS( B( 1, 1 ) )
+      IF( SMLNUM*GAM.GT.BET )
+     $   SCALE = ONE / GAM
+*
+      X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
+      XNORM = ABS( X( 1, 1 ) )
+      RETURN
+*
+*     1 by 2:
+*     TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12]  = [B11 B12]
+*                                       [TR21 TR22]
+*
+   20 CONTINUE
+*
+      SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ),
+     $       ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ),
+     $       SMLNUM )
+      TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+      TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+      IF( LTRANR ) THEN
+         TMP( 2 ) = SGN*TR( 2, 1 )
+         TMP( 3 ) = SGN*TR( 1, 2 )
+      ELSE
+         TMP( 2 ) = SGN*TR( 1, 2 )
+         TMP( 3 ) = SGN*TR( 2, 1 )
+      END IF
+      BTMP( 1 ) = B( 1, 1 )
+      BTMP( 2 ) = B( 1, 2 )
+      GO TO 40
+*
+*     2 by 1:
+*          op[TL11 TL12]*[X11] + ISGN* [X11]*TR11  = [B11]
+*            [TL21 TL22] [X21]         [X21]         [B21]
+*
+   30 CONTINUE
+      SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ),
+     $       ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ),
+     $       SMLNUM )
+      TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+      TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+      IF( LTRANL ) THEN
+         TMP( 2 ) = TL( 1, 2 )
+         TMP( 3 ) = TL( 2, 1 )
+      ELSE
+         TMP( 2 ) = TL( 2, 1 )
+         TMP( 3 ) = TL( 1, 2 )
+      END IF
+      BTMP( 1 ) = B( 1, 1 )
+      BTMP( 2 ) = B( 2, 1 )
+   40 CONTINUE
+*
+*     Solve 2 by 2 system using complete pivoting.
+*     Set pivots less than SMIN to SMIN.
+*
+      IPIV = IDAMAX( 4, TMP, 1 )
+      U11 = TMP( IPIV )
+      IF( ABS( U11 ).LE.SMIN ) THEN
+         INFO = 1
+         U11 = SMIN
+      END IF
+      U12 = TMP( LOCU12( IPIV ) )
+      L21 = TMP( LOCL21( IPIV ) ) / U11
+      U22 = TMP( LOCU22( IPIV ) ) - U12*L21
+      XSWAP = XSWPIV( IPIV )
+      BSWAP = BSWPIV( IPIV )
+      IF( ABS( U22 ).LE.SMIN ) THEN
+         INFO = 1
+         U22 = SMIN
+      END IF
+      IF( BSWAP ) THEN
+         TEMP = BTMP( 2 )
+         BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
+         BTMP( 1 ) = TEMP
+      ELSE
+         BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
+      END IF
+      SCALE = ONE
+      IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
+     $    ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
+         SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
+         BTMP( 1 ) = BTMP( 1 )*SCALE
+         BTMP( 2 ) = BTMP( 2 )*SCALE
+      END IF
+      X2( 2 ) = BTMP( 2 ) / U22
+      X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
+      IF( XSWAP ) THEN
+         TEMP = X2( 2 )
+         X2( 2 ) = X2( 1 )
+         X2( 1 ) = TEMP
+      END IF
+      X( 1, 1 ) = X2( 1 )
+      IF( N1.EQ.1 ) THEN
+         X( 1, 2 ) = X2( 2 )
+         XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+      ELSE
+         X( 2, 1 ) = X2( 2 )
+         XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
+      END IF
+      RETURN
+*
+*     2 by 2:
+*     op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
+*       [TL21 TL22] [X21 X22]        [X21 X22]   [TR21 TR22]   [B21 B22]
+*
+*     Solve equivalent 4 by 4 system using complete pivoting.
+*     Set pivots less than SMIN to SMIN.
+*
+   50 CONTINUE
+      SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
+     $       ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
+      SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
+     $       ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
+      SMIN = MAX( EPS*SMIN, SMLNUM )
+      BTMP( 1 ) = ZERO
+      CALL DCOPY( 16, BTMP, 0, T16, 1 )
+      T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+      T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+      T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+      T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
+      IF( LTRANL ) THEN
+         T16( 1, 2 ) = TL( 2, 1 )
+         T16( 2, 1 ) = TL( 1, 2 )
+         T16( 3, 4 ) = TL( 2, 1 )
+         T16( 4, 3 ) = TL( 1, 2 )
+      ELSE
+         T16( 1, 2 ) = TL( 1, 2 )
+         T16( 2, 1 ) = TL( 2, 1 )
+         T16( 3, 4 ) = TL( 1, 2 )
+         T16( 4, 3 ) = TL( 2, 1 )
+      END IF
+      IF( LTRANR ) THEN
+         T16( 1, 3 ) = SGN*TR( 1, 2 )
+         T16( 2, 4 ) = SGN*TR( 1, 2 )
+         T16( 3, 1 ) = SGN*TR( 2, 1 )
+         T16( 4, 2 ) = SGN*TR( 2, 1 )
+      ELSE
+         T16( 1, 3 ) = SGN*TR( 2, 1 )
+         T16( 2, 4 ) = SGN*TR( 2, 1 )
+         T16( 3, 1 ) = SGN*TR( 1, 2 )
+         T16( 4, 2 ) = SGN*TR( 1, 2 )
+      END IF
+      BTMP( 1 ) = B( 1, 1 )
+      BTMP( 2 ) = B( 2, 1 )
+      BTMP( 3 ) = B( 1, 2 )
+      BTMP( 4 ) = B( 2, 2 )
+*
+*     Perform elimination
+*
+      DO 100 I = 1, 3
+         XMAX = ZERO
+         DO 70 IP = I, 4
+            DO 60 JP = I, 4
+               IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
+                  XMAX = ABS( T16( IP, JP ) )
+                  IPSV = IP
+                  JPSV = JP
+               END IF
+   60       CONTINUE
+   70    CONTINUE
+         IF( IPSV.NE.I ) THEN
+            CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
+            TEMP = BTMP( I )
+            BTMP( I ) = BTMP( IPSV )
+            BTMP( IPSV ) = TEMP
+         END IF
+         IF( JPSV.NE.I )
+     $      CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
+         JPIV( I ) = JPSV
+         IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
+            INFO = 1
+            T16( I, I ) = SMIN
+         END IF
+         DO 90 J = I + 1, 4
+            T16( J, I ) = T16( J, I ) / T16( I, I )
+            BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
+            DO 80 K = I + 1, 4
+               T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
+   80       CONTINUE
+   90    CONTINUE
+  100 CONTINUE
+      IF( ABS( T16( 4, 4 ) ).LT.SMIN )
+     $   T16( 4, 4 ) = SMIN
+      SCALE = ONE
+      IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
+     $    ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
+     $    ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
+     $    ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
+         SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
+     $           ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
+         BTMP( 1 ) = BTMP( 1 )*SCALE
+         BTMP( 2 ) = BTMP( 2 )*SCALE
+         BTMP( 3 ) = BTMP( 3 )*SCALE
+         BTMP( 4 ) = BTMP( 4 )*SCALE
+      END IF
+      DO 120 I = 1, 4
+         K = 5 - I
+         TEMP = ONE / T16( K, K )
+         TMP( K ) = BTMP( K )*TEMP
+         DO 110 J = K + 1, 4
+            TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
+  110    CONTINUE
+  120 CONTINUE
+      DO 130 I = 1, 3
+         IF( JPIV( 4-I ).NE.4-I ) THEN
+            TEMP = TMP( 4-I )
+            TMP( 4-I ) = TMP( JPIV( 4-I ) )
+            TMP( JPIV( 4-I ) ) = TEMP
+         END IF
+  130 CONTINUE
+      X( 1, 1 ) = TMP( 1 )
+      X( 2, 1 ) = TMP( 2 )
+      X( 1, 2 ) = TMP( 3 )
+      X( 2, 2 ) = TMP( 4 )
+      XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ),
+     $        ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
+      RETURN
+*
+*     End of DLASY2
+*
+      END
diff --git a/src/lib/lapack/dlasyf.f b/src/lib/lapack/dlasyf.f
new file mode 100644
index 00000000..67b9c147
--- /dev/null
+++ b/src/lib/lapack/dlasyf.f
@@ -0,0 +1,587 @@
+      SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, KB, LDA, LDW, N, NB
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLASYF computes a partial factorization of a real symmetric matrix A
+*  using the Bunch-Kaufman diagonal pivoting method. The partial
+*  factorization has the form:
+*
+*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:
+*        ( 0  U22 ) (  0   D  ) ( U12' U22' )
+*
+*  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'
+*        ( L21  I ) (  0  A22 ) (  0    I   )
+*
+*  where the order of D is at most NB. The actual order is returned in
+*  the argument KB, and is either NB or NB-1, or N if N <= NB.
+*
+*  DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
+*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
+*  A22 (if UPLO = 'L').
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NB      (input) INTEGER
+*          The maximum number of columns of the matrix A that should be
+*          factored.  NB should be at least 2 to allow for 2-by-2 pivot
+*          blocks.
+*
+*  KB      (output) INTEGER
+*          The number of columns of A that were actually factored.
+*          KB is either NB-1 or NB, or N if N <= NB.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit, A contains details of the partial factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D.
+*          If UPLO = 'U', only the last KB elements of IPIV are set;
+*          if UPLO = 'L', only the first KB elements are set.
+*
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*  W       (workspace) DOUBLE PRECISION array, dimension (LDW,NB)
+*
+*  LDW     (input) INTEGER
+*          The leading dimension of the array W.  LDW >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
+*               has been completed, but the block diagonal matrix D is
+*               exactly singular.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+     $                   KSTEP, KW
+      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
+     $                   ROWMAX, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      EXTERNAL           LSAME, IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Initialize ALPHA for use in choosing pivot block size.
+*
+      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Factorize the trailing columns of A using the upper triangle
+*        of A and working backwards, and compute the matrix W = U12*D
+*        for use in updating A11
+*
+*        K is the main loop index, decreasing from N in steps of 1 or 2
+*
+*        KW is the column of W which corresponds to column K of A
+*
+         K = N
+   10    CONTINUE
+         KW = NB + K - N
+*
+*        Exit from loop
+*
+         IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+     $      GO TO 30
+*
+*        Copy column K of A to column KW of W and update it
+*
+         CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+         IF( K.LT.N )
+     $      CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
+     $                  W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( W( K, KW ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.GT.1 ) THEN
+            IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
+            COLMAX = ABS( W( IMAX, KW ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+*           Column K is zero: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              Copy column IMAX to column KW-1 of W and update it
+*
+               CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+               CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+     $                     W( IMAX+1, KW-1 ), 1 )
+               IF( K.LT.N )
+     $            CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+     $                        LDA, W( IMAX, KW+1 ), LDW, ONE,
+     $                        W( 1, KW-1 ), 1 )
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+               ROWMAX = ABS( W( JMAX, KW-1 ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+*
+*                 copy column KW-1 of W to column KW
+*
+                  CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+               ELSE
+*
+*                 interchange rows and columns K-1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K - KSTEP + 1
+            KKW = NB + KK - N
+*
+*           Updated column KP is already stored in column KKW of W
+*
+            IF( KP.NE.KK ) THEN
+*
+*              Copy non-updated column KK to column KP
+*
+               A( KP, K ) = A( KK, K )
+               CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+*              Interchange rows KK and KP in last KK columns of A and W
+*
+               CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+               CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+     $                     LDW )
+            END IF
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column KW of W now holds
+*
+*              W(k) = U(k)*D(k)
+*
+*              where U(k) is the k-th column of U
+*
+*              Store U(k) in column k of A
+*
+               CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+               R1 = ONE / A( K, K )
+               CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+            ELSE
+*
+*              2-by-2 pivot block D(k): columns KW and KW-1 of W now
+*              hold
+*
+*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
+*              of U
+*
+               IF( K.GT.2 ) THEN
+*
+*                 Store U(k) and U(k-1) in columns k and k-1 of A
+*
+                  D21 = W( K-1, KW )
+                  D11 = W( K, KW ) / D21
+                  D22 = W( K-1, KW-1 ) / D21
+                  T = ONE / ( D11*D22-ONE )
+                  D21 = T / D21
+                  DO 20 J = 1, K - 2
+                     A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
+                     A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
+   20             CONTINUE
+               END IF
+*
+*              Copy D(k) to A
+*
+               A( K-1, K-1 ) = W( K-1, KW-1 )
+               A( K-1, K ) = W( K-1, KW )
+               A( K, K ) = W( K, KW )
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K-1 ) = -KP
+         END IF
+*
+*        Decrease K and return to the start of the main loop
+*
+         K = K - KSTEP
+         GO TO 10
+*
+   30    CONTINUE
+*
+*        Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+*        A11 := A11 - U12*D*U12' = A11 - U12*W'
+*
+*        computing blocks of NB columns at a time
+*
+         DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+            JB = MIN( NB, K-J+1 )
+*
+*           Update the upper triangle of the diagonal block
+*
+            DO 40 JJ = J, J + JB - 1
+               CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+     $                     A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+     $                     A( J, JJ ), 1 )
+   40       CONTINUE
+*
+*           Update the rectangular superdiagonal block
+*
+            CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
+     $                  A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
+     $                  A( 1, J ), LDA )
+   50    CONTINUE
+*
+*        Put U12 in standard form by partially undoing the interchanges
+*        in columns k+1:n
+*
+         J = K + 1
+   60    CONTINUE
+         JJ = J
+         JP = IPIV( J )
+         IF( JP.LT.0 ) THEN
+            JP = -JP
+            J = J + 1
+         END IF
+         J = J + 1
+         IF( JP.NE.JJ .AND. J.LE.N )
+     $      CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+         IF( J.LE.N )
+     $      GO TO 60
+*
+*        Set KB to the number of columns factorized
+*
+         KB = N - K
+*
+      ELSE
+*
+*        Factorize the leading columns of A using the lower triangle
+*        of A and working forwards, and compute the matrix W = L21*D
+*        for use in updating A22
+*
+*        K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+         K = 1
+   70    CONTINUE
+*
+*        Exit from loop
+*
+         IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+     $      GO TO 90
+*
+*        Copy column K of A to column K of W and update it
+*
+         CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+         CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
+     $               W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( W( K, K ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.LT.N ) THEN
+            IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
+            COLMAX = ABS( W( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+*           Column K is zero: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              Copy column IMAX to column K+1 of W and update it
+*
+               CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+               CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+     $                     1 )
+               CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+     $                     LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
+               ROWMAX = ABS( W( JMAX, K+1 ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+*
+*                 copy column K+1 of W to column K
+*
+                  CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+               ELSE
+*
+*                 interchange rows and columns K+1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K + KSTEP - 1
+*
+*           Updated column KP is already stored in column KK of W
+*
+            IF( KP.NE.KK ) THEN
+*
+*              Copy non-updated column KK to column KP
+*
+               A( KP, K ) = A( KK, K )
+               CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+               CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+*              Interchange rows KK and KP in first KK columns of A and W
+*
+               CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+               CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+            END IF
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column k of W now holds
+*
+*              W(k) = L(k)*D(k)
+*
+*              where L(k) is the k-th column of L
+*
+*              Store L(k) in column k of A
+*
+               CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+               IF( K.LT.N ) THEN
+                  R1 = ONE / A( K, K )
+                  CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
+               END IF
+            ELSE
+*
+*              2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+*              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+*              where L(k) and L(k+1) are the k-th and (k+1)-th columns
+*              of L
+*
+               IF( K.LT.N-1 ) THEN
+*
+*                 Store L(k) and L(k+1) in columns k and k+1 of A
+*
+                  D21 = W( K+1, K )
+                  D11 = W( K+1, K+1 ) / D21
+                  D22 = W( K, K ) / D21
+                  T = ONE / ( D11*D22-ONE )
+                  D21 = T / D21
+                  DO 80 J = K + 2, N
+                     A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
+                     A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
+   80             CONTINUE
+               END IF
+*
+*              Copy D(k) to A
+*
+               A( K, K ) = W( K, K )
+               A( K+1, K ) = W( K+1, K )
+               A( K+1, K+1 ) = W( K+1, K+1 )
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K+1 ) = -KP
+         END IF
+*
+*        Increase K and return to the start of the main loop
+*
+         K = K + KSTEP
+         GO TO 70
+*
+   90    CONTINUE
+*
+*        Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+*        A22 := A22 - L21*D*L21' = A22 - L21*W'
+*
+*        computing blocks of NB columns at a time
+*
+         DO 110 J = K, N, NB
+            JB = MIN( NB, N-J+1 )
+*
+*           Update the lower triangle of the diagonal block
+*
+            DO 100 JJ = J, J + JB - 1
+               CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+     $                     A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+     $                     A( JJ, JJ ), 1 )
+  100       CONTINUE
+*
+*           Update the rectangular subdiagonal block
+*
+            IF( J+JB.LE.N )
+     $         CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                     K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+     $                     ONE, A( J+JB, J ), LDA )
+  110    CONTINUE
+*
+*        Put L21 in standard form by partially undoing the interchanges
+*        in columns 1:k-1
+*
+         J = K - 1
+  120    CONTINUE
+         JJ = J
+         JP = IPIV( J )
+         IF( JP.LT.0 ) THEN
+            JP = -JP
+            J = J - 1
+         END IF
+         J = J - 1
+         IF( JP.NE.JJ .AND. J.GE.1 )
+     $      CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+         IF( J.GE.1 )
+     $      GO TO 120
+*
+*        Set KB to the number of columns factorized
+*
+         KB = K - 1
+*
+      END IF
+      RETURN
+*
+*     End of DLASYF
+*
+      END
diff --git a/src/lib/lapack/dlatdf.f b/src/lib/lapack/dlatdf.f
new file mode 100644
index 00000000..91fa46e3
--- /dev/null
+++ b/src/lib/lapack/dlatdf.f
@@ -0,0 +1,237 @@
+      SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
+     $                   JPIV )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IJOB, LDZ, N
+      DOUBLE PRECISION   RDSCAL, RDSUM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      DOUBLE PRECISION   RHS( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATDF uses the LU factorization of the n-by-n matrix Z computed by
+*  DGETC2 and computes a contribution to the reciprocal Dif-estimate
+*  by solving Z * x = b for x, and choosing the r.h.s. b such that
+*  the norm of x is as large as possible. On entry RHS = b holds the
+*  contribution from earlier solved sub-systems, and on return RHS = x.
+*
+*  The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
+*  where P and Q are permutation matrices. L is lower triangular with
+*  unit diagonal elements and U is upper triangular.
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) INTEGER
+*          IJOB = 2: First compute an approximative null-vector e
+*              of Z using DGECON, e is normalized and solve for
+*              Zx = +-e - f with the sign giving the greater value
+*              of 2-norm(x). About 5 times as expensive as Default.
+*          IJOB .ne. 2: Local look ahead strategy where all entries of
+*              the r.h.s. b is choosen as either +1 or -1 (Default).
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Z.
+*
+*  Z       (input) DOUBLE PRECISION array, dimension (LDZ, N)
+*          On entry, the LU part of the factorization of the n-by-n
+*          matrix Z computed by DGETC2:  Z = P * L * U * Q
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDA >= max(1, N).
+*
+*  RHS     (input/output) DOUBLE PRECISION array, dimension N.
+*          On entry, RHS contains contributions from other subsystems.
+*          On exit, RHS contains the solution of the subsystem with
+*          entries acoording to the value of IJOB (see above).
+*
+*  RDSUM   (input/output) DOUBLE PRECISION
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by DTGSYL, where the
+*          scaling factor RDSCAL (see below) has been factored out.
+*          On exit, the corresponding sum of squares updated with the
+*          contributions from the current sub-system.
+*          If TRANS = 'T' RDSUM is not touched.
+*          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
+*
+*  RDSCAL  (input/output) DOUBLE PRECISION
+*          On entry, scaling factor used to prevent overflow in RDSUM.
+*          On exit, RDSCAL is updated w.r.t. the current contributions
+*          in RDSUM.
+*          If TRANS = 'T', RDSCAL is not touched.
+*          NOTE: RDSCAL only makes sense when DTGSY2 is called by
+*                DTGSYL.
+*
+*  IPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  This routine is a further developed implementation of algorithm
+*  BSOLVE in [1] using complete pivoting in the LU factorization.
+*
+*  [1] Bo Kagstrom and Lars Westin,
+*      Generalized Schur Methods with Condition Estimators for
+*      Solving the Generalized Sylvester Equation, IEEE Transactions
+*      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
+*
+*  [2] Peter Poromaa,
+*      On Efficient and Robust Estimators for the Separation
+*      between two Regular Matrix Pairs with Applications in
+*      Condition Estimation. Report IMINF-95.05, Departement of
+*      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXDIM
+      PARAMETER          ( MAXDIM = 8 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J, K
+      DOUBLE PRECISION   BM, BP, PMONE, SMINU, SPLUS, TEMP
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IWORK( MAXDIM )
+      DOUBLE PRECISION   WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP,
+     $                   DSCAL
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DASUM, DDOT
+      EXTERNAL           DASUM, DDOT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( IJOB.NE.2 ) THEN
+*
+*        Apply permutations IPIV to RHS
+*
+         CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
+*
+*        Solve for L-part choosing RHS either to +1 or -1.
+*
+         PMONE = -ONE
+*
+         DO 10 J = 1, N - 1
+            BP = RHS( J ) + ONE
+            BM = RHS( J ) - ONE
+            SPLUS = ONE
+*
+*           Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
+*           SMIN computed more efficiently than in BSOLVE [1].
+*
+            SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
+            SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+            SPLUS = SPLUS*RHS( J )
+            IF( SPLUS.GT.SMINU ) THEN
+               RHS( J ) = BP
+            ELSE IF( SMINU.GT.SPLUS ) THEN
+               RHS( J ) = BM
+            ELSE
+*
+*              In this case the updating sums are equal and we can
+*              choose RHS(J) +1 or -1. The first time this happens
+*              we choose -1, thereafter +1. This is a simple way to
+*              get good estimates of matrices like Byers well-known
+*              example (see [1]). (Not done in BSOLVE.)
+*
+               RHS( J ) = RHS( J ) + PMONE
+               PMONE = ONE
+            END IF
+*
+*           Compute the remaining r.h.s.
+*
+            TEMP = -RHS( J )
+            CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+*
+   10    CONTINUE
+*
+*        Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
+*        in BSOLVE and will hopefully give us a better estimate because
+*        any ill-conditioning of the original matrix is transfered to U
+*        and not to L. U(N, N) is an approximation to sigma_min(LU).
+*
+         CALL DCOPY( N-1, RHS, 1, XP, 1 )
+         XP( N ) = RHS( N ) + ONE
+         RHS( N ) = RHS( N ) - ONE
+         SPLUS = ZERO
+         SMINU = ZERO
+         DO 30 I = N, 1, -1
+            TEMP = ONE / Z( I, I )
+            XP( I ) = XP( I )*TEMP
+            RHS( I ) = RHS( I )*TEMP
+            DO 20 K = I + 1, N
+               XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
+               RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
+   20       CONTINUE
+            SPLUS = SPLUS + ABS( XP( I ) )
+            SMINU = SMINU + ABS( RHS( I ) )
+   30    CONTINUE
+         IF( SPLUS.GT.SMINU )
+     $      CALL DCOPY( N, XP, 1, RHS, 1 )
+*
+*        Apply the permutations JPIV to the computed solution (RHS)
+*
+         CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+*        Compute the sum of squares
+*
+         CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+      ELSE
+*
+*        IJOB = 2, Compute approximate nullvector XM of Z
+*
+         CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
+         CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+*        Compute RHS
+*
+         CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+         TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) )
+         CALL DSCAL( N, TEMP, XM, 1 )
+         CALL DCOPY( N, XM, 1, XP, 1 )
+         CALL DAXPY( N, ONE, RHS, 1, XP, 1 )
+         CALL DAXPY( N, -ONE, XM, 1, RHS, 1 )
+         CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
+         CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
+         IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) )
+     $      CALL DCOPY( N, XP, 1, RHS, 1 )
+*
+*        Compute the sum of squares
+*
+         CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+      END IF
+*
+      RETURN
+*
+*     End of DLATDF
+*
+      END
diff --git a/src/lib/lapack/dlatrd.f b/src/lib/lapack/dlatrd.f
new file mode 100644
index 00000000..27bf9b98
--- /dev/null
+++ b/src/lib/lapack/dlatrd.f
@@ -0,0 +1,258 @@
+      SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, LDW, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATRD reduces NB rows and columns of a real symmetric matrix A to
+*  symmetric tridiagonal form by an orthogonal similarity
+*  transformation Q' * A * Q, and returns the matrices V and W which are
+*  needed to apply the transformation to the unreduced part of A.
+*
+*  If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
+*  matrix, of which the upper triangle is supplied;
+*  if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
+*  matrix, of which the lower triangle is supplied.
+*
+*  This is an auxiliary routine called by DSYTRD.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored:
+*          = 'U': Upper triangular
+*          = 'L': Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NB      (input) INTEGER
+*          The number of rows and columns to be reduced.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit:
+*          if UPLO = 'U', the last NB columns have been reduced to
+*            tridiagonal form, with the diagonal elements overwriting
+*            the diagonal elements of A; the elements above the diagonal
+*            with the array TAU, represent the orthogonal matrix Q as a
+*            product of elementary reflectors;
+*          if UPLO = 'L', the first NB columns have been reduced to
+*            tridiagonal form, with the diagonal elements overwriting
+*            the diagonal elements of A; the elements below the diagonal
+*            with the array TAU, represent the  orthogonal matrix Q as a
+*            product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= (1,N).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
+*          elements of the last NB columns of the reduced matrix;
+*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
+*          the first NB columns of the reduced matrix.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors, stored in
+*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
+*          See Further Details.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (LDW,NB)
+*          The n-by-nb matrix W required to update the unreduced part
+*          of A.
+*
+*  LDW     (input) INTEGER
+*          The leading dimension of the array W. LDW >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n) H(n-1) . . . H(n-nb+1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
+*  and tau in TAU(i-1).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and tau in TAU(i).
+*
+*  The elements of the vectors v together form the n-by-nb matrix V
+*  which is needed, with W, to apply the transformation to the unreduced
+*  part of the matrix, using a symmetric rank-2k update of the form:
+*  A := A - V*W' - W*V'.
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5 and nb = 2:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  a   a   a   v4  v5 )              (  d                  )
+*    (      a   a   v4  v5 )              (  1   d              )
+*    (          a   1   v5 )              (  v1  1   a          )
+*    (              d   1  )              (  v1  v2  a   a      )
+*    (                  d  )              (  v1  v2  a   a   a  )
+*
+*  where d denotes a diagonal element of the reduced matrix, a denotes
+*  an element of the original matrix that is unchanged, and vi denotes
+*  an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, HALF
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IW
+      DOUBLE PRECISION   ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Reduce last NB columns of upper triangle
+*
+         DO 10 I = N, N - NB + 1, -1
+            IW = I - N + NB
+            IF( I.LT.N ) THEN
+*
+*              Update A(1:i,i)
+*
+               CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
+     $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
+            END IF
+            IF( I.GT.1 ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(1:i-2,i)
+*
+               CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
+               E( I-1 ) = A( I-1, I )
+               A( I-1, I ) = ONE
+*
+*              Compute W(1:i-1,i)
+*
+               CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+     $                     ZERO, W( 1, IW ), 1 )
+               IF( I.LT.N ) THEN
+                  CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
+     $                        LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+                  CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+                  CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                        LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+                  CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+               END IF
+               CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+               ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
+     $                 A( 1, I ), 1 )
+               CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
+            END IF
+*
+   10    CONTINUE
+      ELSE
+*
+*        Reduce first NB columns of lower triangle
+*
+         DO 20 I = 1, NB
+*
+*           Update A(i:n,i)
+*
+            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+            CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
+     $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
+            IF( I.LT.N ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(i+2:n,i)
+*
+               CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+     $                      TAU( I ) )
+               E( I ) = A( I+1, I )
+               A( I+1, I ) = ONE
+*
+*              Compute W(i+1:n,i)
+*
+               CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
+     $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+               CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+     $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+               ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
+     $                 A( I+1, I ), 1 )
+               CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+            END IF
+*
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DLATRD
+*
+      END
diff --git a/src/lib/lapack/dlatrs.f b/src/lib/lapack/dlatrs.f
new file mode 100644
index 00000000..bbd3a9e4
--- /dev/null
+++ b/src/lib/lapack/dlatrs.f
@@ -0,0 +1,701 @@
+      SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+     $                   CNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORMIN, TRANS, UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), CNORM( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATRS solves one of the triangular systems
+*
+*     A *x = s*b  or  A'*x = s*b
+*
+*  with scaling to prevent overflow.  Here A is an upper or lower
+*  triangular matrix, A' denotes the transpose of A, x and b are
+*  n-element vectors, and s is a scaling factor, usually less than
+*  or equal to 1, chosen so that the components of x will be less than
+*  the overflow threshold.  If the unscaled problem will not cause
+*  overflow, the Level 2 BLAS routine DTRSV is called.  If the matrix A
+*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+*  non-trivial solution to A*x = 0 is returned.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the matrix A is upper or lower triangular.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  Solve A * x = s*b  (No transpose)
+*          = 'T':  Solve A'* x = s*b  (Transpose)
+*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)
+*
+*  DIAG    (input) CHARACTER*1
+*          Specifies whether or not the matrix A is unit triangular.
+*          = 'N':  Non-unit triangular
+*          = 'U':  Unit triangular
+*
+*  NORMIN  (input) CHARACTER*1
+*          Specifies whether CNORM has been set or not.
+*          = 'Y':  CNORM contains the column norms on entry
+*          = 'N':  CNORM is not set on entry.  On exit, the norms will
+*                  be computed and stored in CNORM.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The triangular matrix A.  If UPLO = 'U', the leading n by n
+*          upper triangular part of the array A contains the upper
+*          triangular matrix, and the strictly lower triangular part of
+*          A is not referenced.  If UPLO = 'L', the leading n by n lower
+*          triangular part of the array A contains the lower triangular
+*          matrix, and the strictly upper triangular part of A is not
+*          referenced.  If DIAG = 'U', the diagonal elements of A are
+*          also not referenced and are assumed to be 1.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max (1,N).
+*
+*  X       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the right hand side b of the triangular system.
+*          On exit, X is overwritten by the solution vector x.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          The scaling factor s for the triangular system
+*             A * x = s*b  or  A'* x = s*b.
+*          If SCALE = 0, the matrix A is singular or badly scaled, and
+*          the vector x is an exact or approximate solution to A*x = 0.
+*
+*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
+*
+*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+*          contains the norm of the off-diagonal part of the j-th column
+*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
+*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+*          must be greater than or equal to the 1-norm.
+*
+*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+*          returns the 1-norm of the offdiagonal part of the j-th column
+*          of A.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -k, the k-th argument had an illegal value
+*
+*  Further Details
+*  ======= =======
+*
+*  A rough bound on x is computed; if that is less than overflow, DTRSV
+*  is called, otherwise, specific code is used which checks for possible
+*  overflow or divide-by-zero at every operation.
+*
+*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
+*  if A is lower triangular is
+*
+*       x[1:n] := b[1:n]
+*       for j = 1, ..., n
+*            x(j) := x(j) / A(j,j)
+*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+*       end
+*
+*  Define bounds on the components of x after j iterations of the loop:
+*     M(j) = bound on x[1:j]
+*     G(j) = bound on x[j+1:n]
+*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+*  Then for iteration j+1 we have
+*     M(j+1) <= G(j) / | A(j+1,j+1) |
+*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+*  where CNORM(j+1) is greater than or equal to the infinity-norm of
+*  column j+1 of A, not counting the diagonal.  Hence
+*
+*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+*                  1<=i<=j
+*  and
+*
+*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+*                                   1<=i< j
+*
+*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
+*  reciprocal of the largest M(j), j=1,..,n, is larger than
+*  max(underflow, 1/overflow).
+*
+*  The bound on x(j) is also used to determine when a step in the
+*  columnwise method can be performed without fear of overflow.  If
+*  the computed bound is greater than a large constant, x is scaled to
+*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic
+*  algorithm for A upper triangular is
+*
+*       for j = 1, ..., n
+*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+*       end
+*
+*  We simultaneously compute two bounds
+*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+*       M(j) = bound on x(i), 1<=i<=j
+*
+*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+*  Then the bound on x(j) is
+*
+*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+*                      1<=i<=j
+*
+*  and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
+      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+     $                   TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DASUM, DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DTRSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DLATRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            DO 10 J = 1, N
+               CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N - 1
+               CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM.
+*
+      IMAX = IDAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = ONE / ( SMLNUM*TMAX )
+         CALL DSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine DTRSV can be used.
+*
+      J = IDAMAX( N, X, 1 )
+      XMAX = ABS( X( J ) )
+      XBND = XMAX
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 50
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 30 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              M(j) = G(j-1) / abs(A(j,j))
+*
+               TJJ = ABS( A( J, J ) )
+               XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+   30       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 50
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   40       CONTINUE
+         END IF
+   50    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A' * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 80
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = ONE / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 60 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+*              M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+               TJJ = ABS( A( J, J ) )
+               IF( XJ.GT.TJJ )
+     $            XBND = XBND*( TJJ / XJ )
+   60       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 80
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   70       CONTINUE
+         END IF
+   80    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = BIGNUM / XMAX
+            CALL DSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            DO 110 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = ABS( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = A( J, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 100
+               END IF
+               TJJ = ABS( TJJS )
+               IF( TJJ.GT.SMLNUM ) THEN
+*
+*                    abs(A(j,j)) > SMLNUM:
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by 1/b(j).
+*
+                        REC = ONE / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                    0 < abs(A(j,j)) <= SMLNUM:
+*
+                  IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+*                       to avoid overflow when dividing by A(j,j).
+*
+                     REC = ( TJJ*BIGNUM ) / XJ
+                     IF( CNORM( J ).GT.ONE ) THEN
+*
+*                          Scale by 1/CNORM(j) to avoid overflow when
+*                          multiplying x(j) times column j.
+*
+                        REC = REC / CNORM( J )
+                     END IF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+                  X( J ) = X( J ) / TJJS
+                  XJ = ABS( X( J ) )
+               ELSE
+*
+*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                    scale = 0, and compute a solution to A*x = 0.
+*
+                  DO 90 I = 1, N
+                     X( I ) = ZERO
+   90             CONTINUE
+                  X( J ) = ONE
+                  XJ = ONE
+                  SCALE = ZERO
+                  XMAX = ZERO
+               END IF
+  100          CONTINUE
+*
+*              Scale x if necessary to avoid overflow when adding a
+*              multiple of column j of A.
+*
+               IF( XJ.GT.ONE ) THEN
+                  REC = ONE / XJ
+                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+*                    Scale x by 1/(2*abs(x(j))).
+*
+                     REC = REC*HALF
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL DSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+                     CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+     $                           1 )
+                     I = IDAMAX( J-1, X, 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + IDAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = ABS( X( I ) )
+                  END IF
+               END IF
+  110       CONTINUE
+*
+         ELSE
+*
+*           Solve A' * x = b
+*
+            DO 160 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = ABS( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = A( J, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                     REC = MIN( ONE, REC*TJJ )
+                     USCAL = USCAL / TJJS
+                  END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL DSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               SUMJ = ZERO
+               IF( USCAL.EQ.ONE ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call DDOT to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 120 I = 1, J - 1
+                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+  120                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 130 I = J + 1, N
+                        SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+  130                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.TSCAL ) THEN
+*
+*                 Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - SUMJ
+                  XJ = ABS( X( J ) )
+                  IF( NOUNIT ) THEN
+                     TJJS = A( J, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 150
+                  END IF
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                  TJJ = ABS( TJJS )
+                  IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                     IF( TJJ.LT.ONE ) THEN
+                        IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                           REC = ONE / XJ
+                           CALL DSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                       0 < abs(A(j,j)) <= SMLNUM:
+*
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+                        REC = ( TJJ*BIGNUM ) / XJ
+                        CALL DSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = X( J ) / TJJS
+                  ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0, and compute a solution to A'*x = 0.
+*
+                     DO 140 I = 1, N
+                        X( I ) = ZERO
+  140                CONTINUE
+                     X( J ) = ONE
+                     SCALE = ZERO
+                     XMAX = ZERO
+                  END IF
+  150             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j)  - sumj if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = X( J ) / TJJS - SUMJ
+               END IF
+               XMAX = MAX( XMAX, ABS( X( J ) ) )
+  160       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DLATRS
+*
+      END
diff --git a/src/lib/lapack/dlatrz.f b/src/lib/lapack/dlatrz.f
new file mode 100644
index 00000000..e1a2cf97
--- /dev/null
+++ b/src/lib/lapack/dlatrz.f
@@ -0,0 +1,127 @@
+      SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            L, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
+*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means
+*  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal
+*  matrix and, R and A1 are M-by-M upper triangular matrices.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing the
+*          meaningful part of the Householder vectors. N-M >= L >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the leading M-by-N upper trapezoidal part of the
+*          array A must contain the matrix to be factorized.
+*          On exit, the leading M-by-M upper triangular part of A
+*          contains the upper triangular matrix R, and elements N-L+1 to
+*          N of the first M rows of A, with the array TAU, represent the
+*          orthogonal matrix Z as a product of M elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The factorization is obtained by Householder's method.  The kth
+*  transformation matrix, Z( k ), which is used to introduce zeros into
+*  the ( m - k + 1 )th row of A, is given in the form
+*
+*     Z( k ) = ( I     0   ),
+*              ( 0  T( k ) )
+*
+*  where
+*
+*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
+*                                                 (   0    )
+*                                                 ( z( k ) )
+*
+*  tau is a scalar and z( k ) is an l element vector. tau and z( k )
+*  are chosen to annihilate the elements of the kth row of A2.
+*
+*  The scalar tau is returned in the kth element of TAU and the vector
+*  u( k ) in the kth row of A2, such that the elements of z( k ) are
+*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
+*  the upper triangular part of A1.
+*
+*  Z is given by
+*
+*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFG, DLARZ
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      DO 20 I = M, 1, -1
+*
+*        Generate elementary reflector H(i) to annihilate
+*        [ A(i,i) A(i,n-l+1:n) ]
+*
+         CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
+*
+*        Apply H(i) to A(1:i-1,i:n) from the right
+*
+         CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
+     $               TAU( I ), A( 1, I ), LDA, WORK )
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of DLATRZ
+*
+      END
diff --git a/src/lib/lapack/dlatzm.f b/src/lib/lapack/dlatzm.f
new file mode 100644
index 00000000..2467ab60
--- /dev/null
+++ b/src/lib/lapack/dlatzm.f
@@ -0,0 +1,142 @@
+      SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, LDC, M, N
+      DOUBLE PRECISION   TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DORMRZ.
+*
+*  DLATZM applies a Householder matrix generated by DTZRQF to a matrix.
+*
+*  Let P = I - tau*u*u',   u = ( 1 ),
+*                              ( v )
+*  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
+*  SIDE = 'R'.
+*
+*  If SIDE equals 'L', let
+*         C = [ C1 ] 1
+*             [ C2 ] m-1
+*               n
+*  Then C is overwritten by P*C.
+*
+*  If SIDE equals 'R', let
+*         C = [ C1, C2 ] m
+*                1  n-1
+*  Then C is overwritten by C*P.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form P * C
+*          = 'R': form C * P
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) DOUBLE PRECISION array, dimension
+*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*          The vector v in the representation of P. V is not used
+*          if TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0
+*
+*  TAU     (input) DOUBLE PRECISION
+*          The value tau in the representation of P.
+*
+*  C1      (input/output) DOUBLE PRECISION array, dimension
+*                         (LDC,N) if SIDE = 'L'
+*                         (M,1)   if SIDE = 'R'
+*          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
+*          if SIDE = 'R'.
+*
+*          On exit, the first row of P*C if SIDE = 'L', or the first
+*          column of C*P if SIDE = 'R'.
+*
+*  C2      (input/output) DOUBLE PRECISION array, dimension
+*                         (LDC, N)   if SIDE = 'L'
+*                         (LDC, N-1) if SIDE = 'R'
+*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
+*          m x (n - 1) matrix C2 if SIDE = 'R'.
+*
+*          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
+*          if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the arrays C1 and C2. LDC >= (1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                      (N) if SIDE = 'L'
+*                      (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )
+     $   RETURN
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        w := C1 + v' * C2
+*
+         CALL DCOPY( N, C1, LDC, WORK, 1 )
+         CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+*        [ C2 ]    [ C2 ]        [ v ]
+*
+         CALL DAXPY( N, -TAU, WORK, 1, C1, LDC )
+         CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        w := C1 + C2 * v
+*
+         CALL DCOPY( M, C1, 1, WORK, 1 )
+         CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+     $               WORK, 1 )
+*
+*        [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+         CALL DAXPY( M, -TAU, WORK, 1, C1, 1 )
+         CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+      END IF
+*
+      RETURN
+*
+*     End of DLATZM
+*
+      END
diff --git a/src/lib/lapack/dlazq3.f b/src/lib/lapack/dlazq3.f
new file mode 100644
index 00000000..784248f7
--- /dev/null
+++ b/src/lib/lapack/dlazq3.f
@@ -0,0 +1,302 @@
+      SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+     $                   ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+     $                   DN2, TAU )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            I0, ITER, N0, NDIV, NFAIL, PP, TTYPE
+      DOUBLE PRECISION   DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
+     $                   SIGMA, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+*  In case of failure it changes shifts, and tries again until output
+*  is positive.
+*
+*  Arguments
+*  =========
+*
+*  I0     (input) INTEGER
+*         First index.
+*
+*  N0     (input) INTEGER
+*         Last index.
+*
+*  Z      (input) DOUBLE PRECISION array, dimension ( 4*N )
+*         Z holds the qd array.
+*
+*  PP     (input) INTEGER
+*         PP=0 for ping, PP=1 for pong.
+*
+*  DMIN   (output) DOUBLE PRECISION
+*         Minimum value of d.
+*
+*  SIGMA  (output) DOUBLE PRECISION
+*         Sum of shifts used in current segment.
+*
+*  DESIG  (input/output) DOUBLE PRECISION
+*         Lower order part of SIGMA
+*
+*  QMAX   (input) DOUBLE PRECISION
+*         Maximum value of q.
+*
+*  NFAIL  (output) INTEGER
+*         Number of times shift was too big.
+*
+*  ITER   (output) INTEGER
+*         Number of iterations.
+*
+*  NDIV   (output) INTEGER
+*         Number of divisions.
+*
+*  IEEE   (input) LOGICAL
+*         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
+*
+*  TTYPE  (input/output) INTEGER
+*         Shift type.  TTYPE is passed as an argument in order to save
+*         its value between calls to DLAZQ3
+*
+*  DMIN1  (input/output) REAL
+*  DMIN2  (input/output) REAL
+*  DN     (input/output) REAL
+*  DN1    (input/output) REAL
+*  DN2    (input/output) REAL
+*  TAU    (input/output) REAL
+*         These are passed as arguments in order to save their values
+*         between calls to DLAZQ3
+*
+*  This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1,
+*  DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
+*  declaring them in a SAVE statment.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   CBIAS
+      PARAMETER          ( CBIAS = 1.50D0 )
+      DOUBLE PRECISION   ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+      PARAMETER          ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
+     $                     ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IPN4, J4, N0IN, NN
+      DOUBLE PRECISION   EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASQ5, DLASQ6, DLAZQ4
+*     ..
+*     .. External Function ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      N0IN   = N0
+      EPS    = DLAMCH( 'Precision' )
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      TOL    = EPS*HUNDRD
+      TOL2   = TOL**2
+      G      = ZERO
+*
+*     Check for deflation.
+*
+   10 CONTINUE
+*
+      IF( N0.LT.I0 )
+     $   RETURN
+      IF( N0.EQ.I0 )
+     $   GO TO 20
+      NN = 4*N0 + PP
+      IF( N0.EQ.( I0+1 ) )
+     $   GO TO 40
+*
+*     Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+      IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+     $    Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+     $   GO TO 30
+*
+   20 CONTINUE
+*
+      Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+      N0 = N0 - 1
+      GO TO 10
+*
+*     Check  whether E(N0-2) is negligible, 2 eigenvalues.
+*
+   30 CONTINUE
+*
+      IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+     $    Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+     $   GO TO 50
+*
+   40 CONTINUE
+*
+      IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+         S = Z( NN-3 )
+         Z( NN-3 ) = Z( NN-7 )
+         Z( NN-7 ) = S
+      END IF
+      IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+         T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+         S = Z( NN-3 )*( Z( NN-5 ) / T )
+         IF( S.LE.T ) THEN
+            S = Z( NN-3 )*( Z( NN-5 ) /
+     $          ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+         ELSE
+            S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+         END IF
+         T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+         Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+         Z( NN-7 ) = T
+      END IF
+      Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+      Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+      N0 = N0 - 2
+      GO TO 10
+*
+   50 CONTINUE
+*
+*     Reverse the qd-array, if warranted.
+*
+      IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+         IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+            IPN4 = 4*( I0+N0 )
+            DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+               TEMP = Z( J4-3 )
+               Z( J4-3 ) = Z( IPN4-J4-3 )
+               Z( IPN4-J4-3 ) = TEMP
+               TEMP = Z( J4-2 )
+               Z( J4-2 ) = Z( IPN4-J4-2 )
+               Z( IPN4-J4-2 ) = TEMP
+               TEMP = Z( J4-1 )
+               Z( J4-1 ) = Z( IPN4-J4-5 )
+               Z( IPN4-J4-5 ) = TEMP
+               TEMP = Z( J4 )
+               Z( J4 ) = Z( IPN4-J4-4 )
+               Z( IPN4-J4-4 ) = TEMP
+   60       CONTINUE
+            IF( N0-I0.LE.4 ) THEN
+               Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+               Z( 4*N0-PP ) = Z( 4*I0-PP )
+            END IF
+            DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+            Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+     $                            Z( 4*I0+PP+3 ) )
+            Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+     $                          Z( 4*I0-PP+4 ) )
+            QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+            DMIN = -ZERO
+         END IF
+      END IF
+*
+      IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+     $    Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+*        Choose a shift.
+*
+         CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+     $                DN2, TAU, TTYPE, G )
+*
+*        Call dqds until DMIN > 0.
+*
+   80    CONTINUE
+*
+         CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+     $                DN1, DN2, IEEE )
+*
+         NDIV = NDIV + ( N0-I0+2 )
+         ITER = ITER + 1
+*
+*        Check status.
+*
+         IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+*           Success.
+*
+            GO TO 100
+*
+         ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+     $            Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+     $            ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+*           Convergence hidden by negative DN.
+*
+            Z( 4*( N0-1 )-PP+2 ) = ZERO
+            DMIN = ZERO
+            GO TO 100
+         ELSE IF( DMIN.LT.ZERO ) THEN
+*
+*           TAU too big. Select new TAU and try again.
+*
+            NFAIL = NFAIL + 1
+            IF( TTYPE.LT.-22 ) THEN
+*
+*              Failed twice. Play it safe.
+*
+               TAU = ZERO
+            ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+*              Late failure. Gives excellent shift.
+*
+               TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+               TTYPE = TTYPE - 11
+            ELSE
+*
+*              Early failure. Divide by 4.
+*
+               TAU = QURTR*TAU
+               TTYPE = TTYPE - 12
+            END IF
+            GO TO 80
+         ELSE IF( DMIN.NE.DMIN ) THEN
+*
+*           NaN.
+*
+            TAU = ZERO
+            GO TO 80
+         ELSE
+*
+*           Possible underflow. Play it safe.
+*
+            GO TO 90
+         END IF
+      END IF
+*
+*     Risk of underflow.
+*
+   90 CONTINUE
+      CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+      NDIV = NDIV + ( N0-I0+2 )
+      ITER = ITER + 1
+      TAU = ZERO
+*
+  100 CONTINUE
+      IF( TAU.LT.SIGMA ) THEN
+         DESIG = DESIG + TAU
+         T = SIGMA + DESIG
+         DESIG = DESIG - ( T-SIGMA )
+      ELSE
+         T = SIGMA + TAU
+         DESIG = SIGMA - ( T-TAU ) + DESIG
+      END IF
+      SIGMA = T
+*
+      RETURN
+*
+*     End of DLAZQ3
+*
+      END
diff --git a/src/lib/lapack/dlazq4.f b/src/lib/lapack/dlazq4.f
new file mode 100644
index 00000000..7c257f8d
--- /dev/null
+++ b/src/lib/lapack/dlazq4.f
@@ -0,0 +1,330 @@
+      SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+     $                   DN1, DN2, TAU, TTYPE, G )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            I0, N0, N0IN, PP, TTYPE
+      DOUBLE PRECISION   DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Z( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLAZQ4 computes an approximation TAU to the smallest eigenvalue 
+*  using values of d from the previous transform.
+*
+*  I0    (input) INTEGER
+*        First index.
+*
+*  N0    (input) INTEGER
+*        Last index.
+*
+*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )
+*        Z holds the qd array.
+*
+*  PP    (input) INTEGER
+*        PP=0 for ping, PP=1 for pong.
+*
+*  N0IN  (input) INTEGER
+*        The value of N0 at start of EIGTEST.
+*
+*  DMIN  (input) DOUBLE PRECISION
+*        Minimum value of d.
+*
+*  DMIN1 (input) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ).
+*
+*  DMIN2 (input) DOUBLE PRECISION
+*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+*  DN    (input) DOUBLE PRECISION
+*        d(N)
+*
+*  DN1   (input) DOUBLE PRECISION
+*        d(N-1)
+*
+*  DN2   (input) DOUBLE PRECISION
+*        d(N-2)
+*
+*  TAU   (output) DOUBLE PRECISION
+*        This is the shift.
+*
+*  TTYPE (output) INTEGER
+*        Shift type.
+*
+*  G     (input/output) DOUBLE PRECISION
+*        G is passed as an argument in order to save its value between
+*        calls to DLAZQ4
+*
+*  Further Details
+*  ===============
+*  CNST1 = 9/16
+*
+*  This is a thread safe version of DLASQ4, which passes G through the
+*  argument list in place of declaring G in a SAVE statment.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   CNST1, CNST2, CNST3
+      PARAMETER          ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
+     $                   CNST3 = 1.050D0 )
+      DOUBLE PRECISION   QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+      PARAMETER          ( QURTR = 0.250D0, THIRD = 0.3330D0,
+     $                   HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
+     $                   TWO = 2.0D0, HUNDRD = 100.0D0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I4, NN, NP
+      DOUBLE PRECISION   A2, B1, B2, GAM, GAP1, GAP2, S
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     A negative DMIN forces the shift to take that absolute value
+*     TTYPE records the type of shift.
+*
+      IF( DMIN.LE.ZERO ) THEN
+         TAU = -DMIN
+         TTYPE = -1
+         RETURN
+      END IF
+*       
+      NN = 4*N0 + PP
+      IF( N0IN.EQ.N0 ) THEN
+*
+*        No eigenvalues deflated.
+*
+         IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+            B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+            B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+            A2 = Z( NN-7 ) + Z( NN-5 )
+*
+*           Cases 2 and 3.
+*
+            IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+               GAP2 = DMIN2 - A2 - DMIN2*QURTR
+               IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+                  GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+               ELSE
+                  GAP1 = A2 - DN - ( B1+B2 )
+               END IF
+               IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+                  S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+                  TTYPE = -2
+               ELSE
+                  S = ZERO
+                  IF( DN.GT.B1 )
+     $               S = DN - B1
+                  IF( A2.GT.( B1+B2 ) )
+     $               S = MIN( S, A2-( B1+B2 ) )
+                  S = MAX( S, THIRD*DMIN )
+                  TTYPE = -3
+               END IF
+            ELSE
+*
+*              Case 4.
+*
+               TTYPE = -4
+               S = QURTR*DMIN
+               IF( DMIN.EQ.DN ) THEN
+                  GAM = DN
+                  A2 = ZERO
+                  IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+     $               RETURN
+                  B2 = Z( NN-5 ) / Z( NN-7 )
+                  NP = NN - 9
+               ELSE
+                  NP = NN - 2*PP
+                  B2 = Z( NP-2 )
+                  GAM = DN1
+                  IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+     $               RETURN
+                  A2 = Z( NP-4 ) / Z( NP-2 )
+                  IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+     $               RETURN
+                  B2 = Z( NN-9 ) / Z( NN-11 )
+                  NP = NN - 13
+               END IF
+*
+*              Approximate contribution to norm squared from I < NN-1.
+*
+               A2 = A2 + B2
+               DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+                  IF( B2.EQ.ZERO )
+     $               GO TO 20
+                  B1 = B2
+                  IF( Z( I4 ) .GT. Z( I4-2 ) )
+     $               RETURN
+                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+                  A2 = A2 + B2
+                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 
+     $               GO TO 20
+   10          CONTINUE
+   20          CONTINUE
+               A2 = CNST3*A2
+*
+*              Rayleigh quotient residual bound.
+*
+               IF( A2.LT.CNST1 )
+     $            S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+            END IF
+         ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+*           Case 5.
+*
+            TTYPE = -5
+            S = QURTR*DMIN
+*
+*           Compute contribution to norm squared from I > NN-2.
+*
+            NP = NN - 2*PP
+            B1 = Z( NP-2 )
+            B2 = Z( NP-6 )
+            GAM = DN2
+            IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+     $         RETURN
+            A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+*           Approximate contribution to norm squared from I < NN-2.
+*
+            IF( N0-I0.GT.2 ) THEN
+               B2 = Z( NN-13 ) / Z( NN-15 )
+               A2 = A2 + B2
+               DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+                  IF( B2.EQ.ZERO )
+     $               GO TO 40
+                  B1 = B2
+                  IF( Z( I4 ) .GT. Z( I4-2 ) )
+     $               RETURN
+                  B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+                  A2 = A2 + B2
+                  IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) 
+     $               GO TO 40
+   30          CONTINUE
+   40          CONTINUE
+               A2 = CNST3*A2
+            END IF
+*
+            IF( A2.LT.CNST1 )
+     $         S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+         ELSE
+*
+*           Case 6, no information to guide us.
+*
+            IF( TTYPE.EQ.-6 ) THEN
+               G = G + THIRD*( ONE-G )
+            ELSE IF( TTYPE.EQ.-18 ) THEN
+               G = QURTR*THIRD
+            ELSE
+               G = QURTR
+            END IF
+            S = G*DMIN
+            TTYPE = -6
+         END IF
+*
+      ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+*        One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+         IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN 
+*
+*           Cases 7 and 8.
+*
+            TTYPE = -7
+            S = THIRD*DMIN1
+            IF( Z( NN-5 ).GT.Z( NN-7 ) )
+     $         RETURN
+            B1 = Z( NN-5 ) / Z( NN-7 )
+            B2 = B1
+            IF( B2.EQ.ZERO )
+     $         GO TO 60
+            DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+               A2 = B1
+               IF( Z( I4 ).GT.Z( I4-2 ) )
+     $            RETURN
+               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+               B2 = B2 + B1
+               IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) 
+     $            GO TO 60
+   50       CONTINUE
+   60       CONTINUE
+            B2 = SQRT( CNST3*B2 )
+            A2 = DMIN1 / ( ONE+B2**2 )
+            GAP2 = HALF*DMIN2 - A2
+            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+            ELSE 
+               S = MAX( S, A2*( ONE-CNST2*B2 ) )
+               TTYPE = -8
+            END IF
+         ELSE
+*
+*           Case 9.
+*
+            S = QURTR*DMIN1
+            IF( DMIN1.EQ.DN1 )
+     $         S = HALF*DMIN1
+            TTYPE = -9
+         END IF
+*
+      ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+*        Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+*        Cases 10 and 11.
+*
+         IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN 
+            TTYPE = -10
+            S = THIRD*DMIN2
+            IF( Z( NN-5 ).GT.Z( NN-7 ) )
+     $         RETURN
+            B1 = Z( NN-5 ) / Z( NN-7 )
+            B2 = B1
+            IF( B2.EQ.ZERO )
+     $         GO TO 80
+            DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+               IF( Z( I4 ).GT.Z( I4-2 ) )
+     $            RETURN
+               B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+               B2 = B2 + B1
+               IF( HUNDRD*B1.LT.B2 )
+     $            GO TO 80
+   70       CONTINUE
+   80       CONTINUE
+            B2 = SQRT( CNST3*B2 )
+            A2 = DMIN2 / ( ONE+B2**2 )
+            GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+     $             SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+            IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+               S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+            ELSE 
+               S = MAX( S, A2*( ONE-CNST2*B2 ) )
+            END IF
+         ELSE
+            S = QURTR*DMIN2
+            TTYPE = -11
+         END IF
+      ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+*        Case 12, more than two eigenvalues deflated. No information.
+*
+         S = ZERO 
+         TTYPE = -12
+      END IF
+*
+      TAU = S
+      RETURN
+*
+*     End of DLAZQ4
+*
+      END
diff --git a/src/lib/lapack/dopgtr.f b/src/lib/lapack/dopgtr.f
new file mode 100644
index 00000000..cf0901ff
--- /dev/null
+++ b/src/lib/lapack/dopgtr.f
@@ -0,0 +1,160 @@
+      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDQ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DOPGTR generates a real orthogonal matrix Q which is defined as the
+*  product of n-1 elementary reflectors H(i) of order n, as returned by
+*  DSPTRD using packed storage:
+*
+*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangular packed storage used in previous
+*                 call to DSPTRD;
+*          = 'L': Lower triangular packed storage used in previous
+*                 call to DSPTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The vectors which define the elementary reflectors, as
+*          returned by DSPTRD.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DSPTRD.
+*
+*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          The N-by-N orthogonal matrix Q.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IINFO, IJ, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORG2L, DORG2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DOPGTR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to DSPTRD with UPLO = 'U'
+*
+*        Unpack the vectors which define the elementary reflectors and
+*        set the last row and column of Q equal to those of the unit
+*        matrix
+*
+         IJ = 2
+         DO 20 J = 1, N - 1
+            DO 10 I = 1, J - 1
+               Q( I, J ) = AP( IJ )
+               IJ = IJ + 1
+   10       CONTINUE
+            IJ = IJ + 2
+            Q( N, J ) = ZERO
+   20    CONTINUE
+         DO 30 I = 1, N - 1
+            Q( I, N ) = ZERO
+   30    CONTINUE
+         Q( N, N ) = ONE
+*
+*        Generate Q(1:n-1,1:n-1)
+*
+         CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to DSPTRD with UPLO = 'L'.
+*
+*        Unpack the vectors which define the elementary reflectors and
+*        set the first row and column of Q equal to those of the unit
+*        matrix
+*
+         Q( 1, 1 ) = ONE
+         DO 40 I = 2, N
+            Q( I, 1 ) = ZERO
+   40    CONTINUE
+         IJ = 3
+         DO 60 J = 2, N
+            Q( 1, J ) = ZERO
+            DO 50 I = J + 1, N
+               Q( I, J ) = AP( IJ )
+               IJ = IJ + 1
+   50       CONTINUE
+            IJ = IJ + 2
+   60    CONTINUE
+         IF( N.GT.1 ) THEN
+*
+*           Generate Q(2:n,2:n)
+*
+            CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+     $                   IINFO )
+         END IF
+      END IF
+      RETURN
+*
+*     End of DOPGTR
+*
+      END
diff --git a/src/lib/lapack/dorg2l.f b/src/lib/lapack/dorg2l.f
new file mode 100644
index 00000000..a20965fd
--- /dev/null
+++ b/src/lib/lapack/dorg2l.f
@@ -0,0 +1,127 @@
+      SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORG2L generates an m by n real matrix Q with orthonormal columns,
+*  which is defined as the last n columns of a product of k elementary
+*  reflectors of order m
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by DGEQLF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the (n-k+i)-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGEQLF in the last k columns of its array
+*          argument A.
+*          On exit, the m by n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQLF.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORG2L', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Initialise columns 1:n-k to columns of the unit matrix
+*
+      DO 20 J = 1, N - K
+         DO 10 L = 1, M
+            A( L, J ) = ZERO
+   10    CONTINUE
+         A( M-N+J, J ) = ONE
+   20 CONTINUE
+*
+      DO 40 I = 1, K
+         II = N - K + I
+*
+*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
+*
+         A( M-N+II, II ) = ONE
+         CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+     $               LDA, WORK )
+         CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
+         A( M-N+II, II ) = ONE - TAU( I )
+*
+*        Set A(m-k+i+1:m,n-k+i) to zero
+*
+         DO 30 L = M - N + II + 1, M
+            A( L, II ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of DORG2L
+*
+      END
diff --git a/src/lib/lapack/dorg2r.f b/src/lib/lapack/dorg2r.f
new file mode 100644
index 00000000..476e9f70
--- /dev/null
+++ b/src/lib/lapack/dorg2r.f
@@ -0,0 +1,129 @@
+      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORG2R generates an m by n real matrix Q with orthonormal columns,
+*  which is defined as the first n columns of a product of k elementary
+*  reflectors of order m
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by DGEQRF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the i-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGEQRF in the first k columns of its array
+*          argument A.
+*          On exit, the m-by-n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQRF.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORG2R', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Initialise columns k+1:n to columns of the unit matrix
+*
+      DO 20 J = K + 1, N
+         DO 10 L = 1, M
+            A( L, J ) = ZERO
+   10    CONTINUE
+         A( J, J ) = ONE
+   20 CONTINUE
+*
+      DO 40 I = K, 1, -1
+*
+*        Apply H(i) to A(i:m,i:n) from the left
+*
+         IF( I.LT.N ) THEN
+            A( I, I ) = ONE
+            CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                  A( I, I+1 ), LDA, WORK )
+         END IF
+         IF( I.LT.M )
+     $      CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
+         A( I, I ) = ONE - TAU( I )
+*
+*        Set A(1:i-1,i) to zero
+*
+         DO 30 L = 1, I - 1
+            A( L, I ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of DORG2R
+*
+      END
diff --git a/src/lib/lapack/dorgbr.f b/src/lib/lapack/dorgbr.f
new file mode 100644
index 00000000..dc882990
--- /dev/null
+++ b/src/lib/lapack/dorgbr.f
@@ -0,0 +1,244 @@
+      SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGBR generates one of the real orthogonal matrices Q or P**T
+*  determined by DGEBRD when reducing a real matrix A to bidiagonal
+*  form: A = Q * B * P**T.  Q and P**T are defined as products of
+*  elementary reflectors H(i) or G(i) respectively.
+*
+*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
+*  is of order M:
+*  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
+*  columns of Q, where m >= n >= k;
+*  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
+*  M-by-M matrix.
+*
+*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
+*  is of order N:
+*  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
+*  rows of P**T, where n >= m >= k;
+*  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
+*  an N-by-N matrix.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether the matrix Q or the matrix P**T is
+*          required, as defined in the transformation applied by DGEBRD:
+*          = 'Q':  generate Q;
+*          = 'P':  generate P**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q or P**T to be returned.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q or P**T to be returned.
+*          N >= 0.
+*          If VECT = 'Q', M >= N >= min(M,K);
+*          if VECT = 'P', N >= M >= min(N,K).
+*
+*  K       (input) INTEGER
+*          If VECT = 'Q', the number of columns in the original M-by-K
+*          matrix reduced by DGEBRD.
+*          If VECT = 'P', the number of rows in the original K-by-N
+*          matrix reduced by DGEBRD.
+*          K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by DGEBRD.
+*          On exit, the M-by-N matrix Q or P**T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension
+*                                (min(M,K)) if VECT = 'Q'
+*                                (min(N,K)) if VECT = 'P'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i) or G(i), which determines Q or P**T, as
+*          returned by DGEBRD in its array argument TAUQ or TAUP.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
+*          For optimum performance LWORK >= min(M,N)*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTQ
+      INTEGER            I, IINFO, J, LWKOPT, MN, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORGLQ, DORGQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      WANTQ = LSAME( VECT, 'Q' )
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
+     $         K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
+     $         MIN( N, K ) ) ) ) THEN
+         INFO = -3
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -6
+      ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( WANTQ ) THEN
+            NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
+         ELSE
+            NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
+         END IF
+         LWKOPT = MAX( 1, MN )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGBR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Form Q, determined by a call to DGEBRD to reduce an m-by-k
+*        matrix
+*
+         IF( M.GE.K ) THEN
+*
+*           If m >= k, assume m >= n >= k
+*
+            CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+         ELSE
+*
+*           If m < k, assume m = n
+*
+*           Shift the vectors which define the elementary reflectors one
+*           column to the right, and set the first row and column of Q
+*           to those of the unit matrix
+*
+            DO 20 J = M, 2, -1
+               A( 1, J ) = ZERO
+               DO 10 I = J + 1, M
+                  A( I, J ) = A( I, J-1 )
+   10          CONTINUE
+   20       CONTINUE
+            A( 1, 1 ) = ONE
+            DO 30 I = 2, M
+               A( I, 1 ) = ZERO
+   30       CONTINUE
+            IF( M.GT.1 ) THEN
+*
+*              Form Q(2:m,2:m)
+*
+               CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                      LWORK, IINFO )
+            END IF
+         END IF
+      ELSE
+*
+*        Form P', determined by a call to DGEBRD to reduce a k-by-n
+*        matrix
+*
+         IF( K.LT.N ) THEN
+*
+*           If k < n, assume k <= m <= n
+*
+            CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+         ELSE
+*
+*           If k >= n, assume m = n
+*
+*           Shift the vectors which define the elementary reflectors one
+*           row downward, and set the first row and column of P' to
+*           those of the unit matrix
+*
+            A( 1, 1 ) = ONE
+            DO 40 I = 2, N
+               A( I, 1 ) = ZERO
+   40       CONTINUE
+            DO 60 J = 2, N
+               DO 50 I = J - 1, 2, -1
+                  A( I, J ) = A( I-1, J )
+   50          CONTINUE
+               A( 1, J ) = ZERO
+   60       CONTINUE
+            IF( N.GT.1 ) THEN
+*
+*              Form P'(2:n,2:n)
+*
+               CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                      LWORK, IINFO )
+            END IF
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORGBR
+*
+      END
diff --git a/src/lib/lapack/dorghr.f b/src/lib/lapack/dorghr.f
new file mode 100644
index 00000000..1283aece
--- /dev/null
+++ b/src/lib/lapack/dorghr.f
@@ -0,0 +1,164 @@
+      SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGHR generates a real orthogonal matrix Q which is defined as the
+*  product of IHI-ILO elementary reflectors of order N, as returned by
+*  DGEHRD:
+*
+*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI must have the same values as in the previous call
+*          of DGEHRD. Q is equal to the unit matrix except in the
+*          submatrix Q(ilo+1:ihi,ilo+1:ihi).
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by DGEHRD.
+*          On exit, the N-by-N orthogonal matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEHRD.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= IHI-ILO.
+*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LWKOPT, NB, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORGQR, XERBLA
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NH = IHI - ILO
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 )
+         LWKOPT = MAX( 1, NH )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGHR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Shift the vectors which define the elementary reflectors one
+*     column to the right, and set the first ilo and the last n-ihi
+*     rows and columns to those of the unit matrix
+*
+      DO 40 J = IHI, ILO + 1, -1
+         DO 10 I = 1, J - 1
+            A( I, J ) = ZERO
+   10    CONTINUE
+         DO 20 I = J + 1, IHI
+            A( I, J ) = A( I, J-1 )
+   20    CONTINUE
+         DO 30 I = IHI + 1, N
+            A( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      DO 60 J = 1, ILO
+         DO 50 I = 1, N
+            A( I, J ) = ZERO
+   50    CONTINUE
+         A( J, J ) = ONE
+   60 CONTINUE
+      DO 80 J = IHI + 1, N
+         DO 70 I = 1, N
+            A( I, J ) = ZERO
+   70    CONTINUE
+         A( J, J ) = ONE
+   80 CONTINUE
+*
+      IF( NH.GT.0 ) THEN
+*
+*        Generate Q(ilo+1:ihi,ilo+1:ihi)
+*
+         CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+     $                WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORGHR
+*
+      END
diff --git a/src/lib/lapack/dorgl2.f b/src/lib/lapack/dorgl2.f
new file mode 100644
index 00000000..1e08344d
--- /dev/null
+++ b/src/lib/lapack/dorgl2.f
@@ -0,0 +1,133 @@
+      SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGL2 generates an m by n real matrix Q with orthonormal rows,
+*  which is defined as the first m rows of a product of k elementary
+*  reflectors of order n
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by DGELQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the i-th row must contain the vector which defines
+*          the elementary reflector H(i), for i = 1,2,...,k, as returned
+*          by DGELQF in the first k rows of its array argument A.
+*          On exit, the m-by-n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGELQF.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGL2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 )
+     $   RETURN
+*
+      IF( K.LT.M ) THEN
+*
+*        Initialise rows k+1:m to rows of the unit matrix
+*
+         DO 20 J = 1, N
+            DO 10 L = K + 1, M
+               A( L, J ) = ZERO
+   10       CONTINUE
+            IF( J.GT.K .AND. J.LE.M )
+     $         A( J, J ) = ONE
+   20    CONTINUE
+      END IF
+*
+      DO 40 I = K, 1, -1
+*
+*        Apply H(i) to A(i:m,i:n) from the right
+*
+         IF( I.LT.N ) THEN
+            IF( I.LT.M ) THEN
+               A( I, I ) = ONE
+               CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     TAU( I ), A( I+1, I ), LDA, WORK )
+            END IF
+            CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
+         END IF
+         A( I, I ) = ONE - TAU( I )
+*
+*        Set A(i,1:i-1) to zero
+*
+         DO 30 L = 1, I - 1
+            A( I, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of DORGL2
+*
+      END
diff --git a/src/lib/lapack/dorglq.f b/src/lib/lapack/dorglq.f
new file mode 100644
index 00000000..e4f58c96
--- /dev/null
+++ b/src/lib/lapack/dorglq.f
@@ -0,0 +1,215 @@
+      SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
+*  which is defined as the first M rows of a product of K elementary
+*  reflectors of order N
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by DGELQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the i-th row must contain the vector which defines
+*          the elementary reflector H(i), for i = 1,2,...,k, as returned
+*          by DGELQF in the first k rows of its array argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGELQF.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORGL2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
+      LWKOPT = MAX( 1, M )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGLQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the last block.
+*        The first kk rows are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+*        Set A(kk+1:m,1:kk) to zero.
+*
+         DO 20 J = 1, KK
+            DO 10 I = KK + 1, M
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the last or only block.
+*
+      IF( KK.LT.M )
+     $   CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+     $                TAU( KK+1 ), WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = KI + 1, 1, -NB
+            IB = MIN( NB, K-I+1 )
+            IF( I+IB.LE.M ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(i+ib:m,i:n) from the right
+*
+               CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise',
+     $                      M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK,
+     $                      LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ),
+     $                      LDWORK )
+            END IF
+*
+*           Apply H' to columns i:n of current block
+*
+            CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+*
+*           Set columns 1:i-1 of current block to zero
+*
+            DO 40 J = 1, I - 1
+               DO 30 L = I, I + IB - 1
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DORGLQ
+*
+      END
diff --git a/src/lib/lapack/dorgql.f b/src/lib/lapack/dorgql.f
new file mode 100644
index 00000000..1c4896e9
--- /dev/null
+++ b/src/lib/lapack/dorgql.f
@@ -0,0 +1,222 @@
+      SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGQL generates an M-by-N real matrix Q with orthonormal columns,
+*  which is defined as the last N columns of a product of K elementary
+*  reflectors of order M
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by DGEQLF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the (n-k+i)-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGEQLF in the last k columns of its array
+*          argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQLF.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+     $                   NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORG2L, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGQL', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the first block.
+*        The last kk columns are handled by the block method.
+*
+         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+*        Set A(m-kk+1:m,1:n-kk) to zero.
+*
+         DO 20 J = 1, N - KK
+            DO 10 I = M - KK + 1, M
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the first or only block.
+*
+      CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = K - KK + 1, K, NB
+            IB = MIN( NB, K-I+1 )
+            IF( N-K+I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+     $                      A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+               CALL DLARFB( 'Left', 'No transpose', 'Backward',
+     $                      'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+     $                      A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H to rows 1:m-k+i+ib-1 of current block
+*
+            CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
+     $                   TAU( I ), WORK, IINFO )
+*
+*           Set rows m-k+i+ib:m of current block to zero
+*
+            DO 40 J = N - K + I, N - K + I + IB - 1
+               DO 30 L = M - K + I + IB, M
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DORGQL
+*
+      END
diff --git a/src/lib/lapack/dorgqr.f b/src/lib/lapack/dorgqr.f
new file mode 100644
index 00000000..4db0ef5a
--- /dev/null
+++ b/src/lib/lapack/dorgqr.f
@@ -0,0 +1,216 @@
+      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGQR generates an M-by-N real matrix Q with orthonormal columns,
+*  which is defined as the first N columns of a product of K elementary
+*  reflectors of order M
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by DGEQRF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the i-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGEQRF in the first k columns of its array
+*          argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQRF.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORG2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
+      LWKOPT = MAX( 1, N )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGQR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the last block.
+*        The first kk columns are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+*        Set A(1:kk,kk+1:n) to zero.
+*
+         DO 20 J = KK + 1, N
+            DO 10 I = 1, KK
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the last or only block.
+*
+      IF( KK.LT.N )
+     $   CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+     $                TAU( KK+1 ), WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = KI + 1, 1, -NB
+            IB = MIN( NB, K-I+1 )
+            IF( I+IB.LE.N ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(i:m,i+ib:n) from the left
+*
+               CALL DLARFB( 'Left', 'No transpose', 'Forward',
+     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
+     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+     $                      LDA, WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H to rows i:m of current block
+*
+            CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+*
+*           Set rows 1:i-1 of current block to zero
+*
+            DO 40 J = I, I + IB - 1
+               DO 30 L = 1, I - 1
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DORGQR
+*
+      END
diff --git a/src/lib/lapack/dorgr2.f b/src/lib/lapack/dorgr2.f
new file mode 100644
index 00000000..9da45c5f
--- /dev/null
+++ b/src/lib/lapack/dorgr2.f
@@ -0,0 +1,131 @@
+      SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGR2 generates an m by n real matrix Q with orthonormal rows,
+*  which is defined as the last m rows of a product of k elementary
+*  reflectors of order n
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by DGERQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the (m-k+i)-th row must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGERQF in the last k rows of its array argument
+*          A.
+*          On exit, the m by n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGERQF.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGR2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 )
+     $   RETURN
+*
+      IF( K.LT.M ) THEN
+*
+*        Initialise rows 1:m-k to rows of the unit matrix
+*
+         DO 20 J = 1, N
+            DO 10 L = 1, M - K
+               A( L, J ) = ZERO
+   10       CONTINUE
+            IF( J.GT.N-M .AND. J.LE.N-K )
+     $         A( M-N+J, J ) = ONE
+   20    CONTINUE
+      END IF
+*
+      DO 40 I = 1, K
+         II = M - K + I
+*
+*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
+*
+         A( II, N-M+II ) = ONE
+         CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
+     $               A, LDA, WORK )
+         CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
+         A( II, N-M+II ) = ONE - TAU( I )
+*
+*        Set A(m-k+i,n-k+i+1:n) to zero
+*
+         DO 30 L = N - M + II + 1, N
+            A( II, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of DORGR2
+*
+      END
diff --git a/src/lib/lapack/dorgrq.f b/src/lib/lapack/dorgrq.f
new file mode 100644
index 00000000..11633403
--- /dev/null
+++ b/src/lib/lapack/dorgrq.f
@@ -0,0 +1,222 @@
+      SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGRQ generates an M-by-N real matrix Q with orthonormal rows,
+*  which is defined as the last M rows of a product of K elementary
+*  reflectors of order N
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by DGERQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the (m-k+i)-th row must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by DGERQF in the last k rows of its array argument
+*          A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGERQF.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORGR2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.LE.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 )
+            LWKOPT = M*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGRQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DORGRQ', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the first block.
+*        The last kk rows are handled by the block method.
+*
+         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+*        Set A(1:m-kk,n-kk+1:n) to zero.
+*
+         DO 20 J = N - KK + 1, N
+            DO 10 I = 1, M - KK
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the first or only block.
+*
+      CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = K - KK + 1, K, NB
+            IB = MIN( NB, K-I+1 )
+            II = M - K + I
+            IF( II.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+     $                      A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+               CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise',
+     $                      II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK,
+     $                      LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H' to columns 1:n-k+i+ib-1 of current block
+*
+            CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
+     $                   WORK, IINFO )
+*
+*           Set columns n-k+i+ib:n of current block to zero
+*
+            DO 40 L = N - K + I + IB, N
+               DO 30 J = II, II + IB - 1
+                  A( J, L ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of DORGRQ
+*
+      END
diff --git a/src/lib/lapack/dorgtr.f b/src/lib/lapack/dorgtr.f
new file mode 100644
index 00000000..4c72d031
--- /dev/null
+++ b/src/lib/lapack/dorgtr.f
@@ -0,0 +1,183 @@
+      SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORGTR generates a real orthogonal matrix Q which is defined as the
+*  product of n-1 elementary reflectors of order N, as returned by
+*  DSYTRD:
+*
+*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from DSYTRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from DSYTRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by DSYTRD.
+*          On exit, the N-by-N orthogonal matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DSYTRD.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,N-1).
+*          For optimum performance LWORK >= (N-1)*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, J, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORGQL, DORGQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
+         ELSE
+            NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
+         END IF
+         LWKOPT = MAX( 1, N-1 )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORGTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to DSYTRD with UPLO = 'U'
+*
+*        Shift the vectors which define the elementary reflectors one
+*        column to the left, and set the last row and column of Q to
+*        those of the unit matrix
+*
+         DO 20 J = 1, N - 1
+            DO 10 I = 1, J - 1
+               A( I, J ) = A( I, J+1 )
+   10       CONTINUE
+            A( N, J ) = ZERO
+   20    CONTINUE
+         DO 30 I = 1, N - 1
+            A( I, N ) = ZERO
+   30    CONTINUE
+         A( N, N ) = ONE
+*
+*        Generate Q(1:n-1,1:n-1)
+*
+         CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to DSYTRD with UPLO = 'L'.
+*
+*        Shift the vectors which define the elementary reflectors one
+*        column to the right, and set the first row and column of Q to
+*        those of the unit matrix
+*
+         DO 50 J = N, 2, -1
+            A( 1, J ) = ZERO
+            DO 40 I = J + 1, N
+               A( I, J ) = A( I, J-1 )
+   40       CONTINUE
+   50    CONTINUE
+         A( 1, 1 ) = ONE
+         DO 60 I = 2, N
+            A( I, 1 ) = ZERO
+   60    CONTINUE
+         IF( N.GT.1 ) THEN
+*
+*           Generate Q(2:n,2:n)
+*
+            CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                   LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORGTR
+*
+      END
diff --git a/src/lib/lapack/dorm2l.f b/src/lib/lapack/dorm2l.f
new file mode 100644
index 00000000..27120075
--- /dev/null
+++ b/src/lib/lapack/dorm2l.f
@@ -0,0 +1,193 @@
+      SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORM2L overwrites the general real m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k) . . . H(2) H(1)
+*
+*  as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'T': apply Q' (Transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGEQLF in the last k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQLF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORM2L', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+     $     THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+      ELSE
+         MI = M
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i)
+*
+         AII = A( NQ-K+I, I )
+         A( NQ-K+I, I ) = ONE
+         CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+     $               WORK )
+         A( NQ-K+I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DORM2L
+*
+      END
diff --git a/src/lib/lapack/dorm2r.f b/src/lib/lapack/dorm2r.f
new file mode 100644
index 00000000..79c9ef35
--- /dev/null
+++ b/src/lib/lapack/dorm2r.f
@@ -0,0 +1,197 @@
+      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORM2R overwrites the general real m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'T': apply Q' (Transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGEQRF in the first k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQRF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORM2R', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+     $     THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JC = 1
+      ELSE
+         MI = M
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i)
+*
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
+     $               LDC, WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DORM2R
+*
+      END
diff --git a/src/lib/lapack/dormbr.f b/src/lib/lapack/dormbr.f
new file mode 100644
index 00000000..8066b893
--- /dev/null
+++ b/src/lib/lapack/dormbr.f
@@ -0,0 +1,281 @@
+      SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+     $                   LDC, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS, VECT
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
+*  with
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
+*  with
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      P * C          C * P
+*  TRANS = 'T':      P**T * C       C * P**T
+*
+*  Here Q and P**T are the orthogonal matrices determined by DGEBRD when
+*  reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
+*  P**T are defined as products of elementary reflectors H(i) and G(i)
+*  respectively.
+*
+*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
+*  order of the orthogonal matrix Q or P**T that is applied.
+*
+*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
+*  if nq >= k, Q = H(1) H(2) . . . H(k);
+*  if nq < k, Q = H(1) H(2) . . . H(nq-1).
+*
+*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
+*  if k < nq, P = G(1) G(2) . . . G(k);
+*  if k >= nq, P = G(1) G(2) . . . G(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'Q': apply Q or Q**T;
+*          = 'P': apply P or P**T.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q, Q**T, P or P**T from the Left;
+*          = 'R': apply Q, Q**T, P or P**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q  or P;
+*          = 'T':  Transpose, apply Q**T or P**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          If VECT = 'Q', the number of columns in the original
+*          matrix reduced by DGEBRD.
+*          If VECT = 'P', the number of rows in the original
+*          matrix reduced by DGEBRD.
+*          K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                                (LDA,min(nq,K)) if VECT = 'Q'
+*                                (LDA,nq)        if VECT = 'P'
+*          The vectors which define the elementary reflectors H(i) and
+*          G(i), whose products determine the matrices Q and P, as
+*          returned by DGEBRD.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If VECT = 'Q', LDA >= max(1,nq);
+*          if VECT = 'P', LDA >= max(1,min(nq,K)).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (min(nq,K))
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i) or G(i) which determines Q or P, as returned
+*          by DGEBRD in the array argument TAUQ or TAUP.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
+*          or P*C or P**T*C or C*P or C*P**T.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORMLQ, DORMQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      APPLYQ = LSAME( VECT, 'Q' )
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q or P and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
+     $         ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
+     $          THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -13
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( APPLYQ ) THEN
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
+     $              -1 )
+            ELSE
+               NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
+     $              -1 )
+            END IF
+         ELSE
+            IF( LEFT ) THEN
+               NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1,
+     $              -1 )
+            ELSE
+               NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1,
+     $              -1 )
+            END IF
+         END IF
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMBR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      WORK( 1 ) = 1
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( APPLYQ ) THEN
+*
+*        Apply Q
+*
+         IF( NQ.GE.K ) THEN
+*
+*           Q was determined by a call to DGEBRD with nq >= k
+*
+            CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, IINFO )
+         ELSE IF( NQ.GT.1 ) THEN
+*
+*           Q was determined by a call to DGEBRD with nq < k
+*
+            IF( LEFT ) THEN
+               MI = M - 1
+               NI = N
+               I1 = 2
+               I2 = 1
+            ELSE
+               MI = M
+               NI = N - 1
+               I1 = 1
+               I2 = 2
+            END IF
+            CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+     $                   C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+         END IF
+      ELSE
+*
+*        Apply P
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'T'
+         ELSE
+            TRANST = 'N'
+         END IF
+         IF( NQ.GT.K ) THEN
+*
+*           P was determined by a call to DGEBRD with nq > k
+*
+            CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, IINFO )
+         ELSE IF( NQ.GT.1 ) THEN
+*
+*           P was determined by a call to DGEBRD with nq <= k
+*
+            IF( LEFT ) THEN
+               MI = M - 1
+               NI = N
+               I1 = 2
+               I2 = 1
+            ELSE
+               MI = M
+               NI = N - 1
+               I1 = 1
+               I2 = 2
+            END IF
+            CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
+     $                   TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMBR
+*
+      END
diff --git a/src/lib/lapack/dormhr.f b/src/lib/lapack/dormhr.f
new file mode 100644
index 00000000..5862538e
--- /dev/null
+++ b/src/lib/lapack/dormhr.f
@@ -0,0 +1,201 @@
+      SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
+     $                   LDC, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            IHI, ILO, INFO, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMHR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix of order nq, with nq = m if
+*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+*  IHI-ILO elementary reflectors, as returned by DGEHRD:
+*
+*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI must have the same values as in the previous call
+*          of DGEHRD. Q is equal to the unit matrix except in the
+*          submatrix Q(ilo+1:ihi,ilo+1:ihi).
+*          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
+*          ILO = 1 and IHI = 0, if M = 0;
+*          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
+*          ILO = 1 and IHI = 0, if N = 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L'
+*                               (LDA,N) if SIDE = 'R'
+*          The vectors which define the elementary reflectors, as
+*          returned by DGEHRD.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension
+*                               (M-1) if SIDE = 'L'
+*                               (N-1) if SIDE = 'R'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEHRD.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DORMQR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NH = IHI - ILO
+      LEFT = LSAME( SIDE, 'L' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
+         INFO = -5
+      ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -13
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( LEFT ) THEN
+            NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 )
+         ELSE
+            NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 )
+         END IF
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMHR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( LEFT ) THEN
+         MI = NH
+         NI = N
+         I1 = ILO + 1
+         I2 = 1
+      ELSE
+         MI = M
+         NI = NH
+         I1 = 1
+         I2 = ILO + 1
+      END IF
+*
+      CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
+     $             TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMHR
+*
+      END
diff --git a/src/lib/lapack/dorml2.f b/src/lib/lapack/dorml2.f
new file mode 100644
index 00000000..d3941c9a
--- /dev/null
+++ b/src/lib/lapack/dorml2.f
@@ -0,0 +1,197 @@
+      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORML2 overwrites the general real m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k) . . . H(2) H(1)
+*
+*  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'T': apply Q' (Transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGELQF in the first k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGELQF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORML2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+     $     THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JC = 1
+      ELSE
+         MI = M
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i)
+*
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+     $               C( IC, JC ), LDC, WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DORML2
+*
+      END
diff --git a/src/lib/lapack/dormlq.f b/src/lib/lapack/dormlq.f
new file mode 100644
index 00000000..f0c68ef2
--- /dev/null
+++ b/src/lib/lapack/dormlq.f
@@ -0,0 +1,267 @@
+      SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMLQ overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k) . . . H(2) H(1)
+*
+*  as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGELQF in the first k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGELQF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORML2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.  NB may be at most NBMAX, where NBMAX
+*        is used to define the local array T.
+*
+         NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMLQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'T'
+         ELSE
+            TRANST = 'N'
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i) H(i+1) . . . H(i+ib-1)
+*
+            CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
+     $                   LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
+     $                   A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK,
+     $                   LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMLQ
+*
+      END
diff --git a/src/lib/lapack/dormql.f b/src/lib/lapack/dormql.f
new file mode 100644
index 00000000..f3370f10
--- /dev/null
+++ b/src/lib/lapack/dormql.f
@@ -0,0 +1,261 @@
+      SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMQL overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k) . . . H(2) H(1)
+*
+*  as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGEQLF in the last k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQLF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      INTEGER            I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+     $                   MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORM2L, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = MAX( 1, N )
+      ELSE
+         NQ = N
+         NW = MAX( 1, M )
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+*
+*           Determine the block size.  NB may be at most NBMAX, where
+*           NBMAX is used to define the local array T.
+*
+            NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N,
+     $                               K, -1 ) )
+            LWKOPT = NW*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMQL', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i+ib-1) . . . H(i+1) H(i)
+*
+            CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
+     $                   A( 1, I ), LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+               MI = M - K + I + IB - 1
+            ELSE
+*
+*              H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+               NI = N - K + I + IB - 1
+            END IF
+*
+*           Apply H or H'
+*
+            CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
+     $                   IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
+     $                   LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMQL
+*
+      END
diff --git a/src/lib/lapack/dormqr.f b/src/lib/lapack/dormqr.f
new file mode 100644
index 00000000..ee372695
--- /dev/null
+++ b/src/lib/lapack/dormqr.f
@@ -0,0 +1,260 @@
+      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMQR overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGEQRF in the first k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGEQRF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORM2R, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.  NB may be at most NBMAX, where NBMAX
+*        is used to define the local array T.
+*
+         NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMQR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i) H(i+1) . . . H(i+ib-1)
+*
+            CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
+     $                   LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
+     $                   IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
+     $                   WORK, LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMQR
+*
+      END
diff --git a/src/lib/lapack/dormr2.f b/src/lib/lapack/dormr2.f
new file mode 100644
index 00000000..994552fb
--- /dev/null
+++ b/src/lib/lapack/dormr2.f
@@ -0,0 +1,193 @@
+      SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMR2 overwrites the general real m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'T': apply Q' (Transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGERQF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGERQF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, MI, NI, NQ
+      DOUBLE PRECISION   AII
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMR2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+     $     THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+      ELSE
+         MI = M
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) is applied to C(1:m-k+i,1:n)
+*
+            MI = M - K + I
+         ELSE
+*
+*           H(i) is applied to C(1:m,1:n-k+i)
+*
+            NI = N - K + I
+         END IF
+*
+*        Apply H(i)
+*
+         AII = A( I, NQ-K+I )
+         A( I, NQ-K+I ) = ONE
+         CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
+     $               WORK )
+         A( I, NQ-K+I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of DORMR2
+*
+      END
diff --git a/src/lib/lapack/dormr3.f b/src/lib/lapack/dormr3.f
new file mode 100644
index 00000000..7bdcb856
--- /dev/null
+++ b/src/lib/lapack/dormr3.f
@@ -0,0 +1,206 @@
+      SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMR3 overwrites the general real m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'T', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'T': apply Q' (Transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing
+*          the meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DTZRZF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DTZRZF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the m-by-n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARZ, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+     $         ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMR3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JA = M - L + 1
+         JC = 1
+      ELSE
+         MI = M
+         JA = N - L + 1
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) or H(i)' is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
+     $               C( IC, JC ), LDC, WORK )
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of DORMR3
+*
+      END
diff --git a/src/lib/lapack/dormrq.f b/src/lib/lapack/dormrq.f
new file mode 100644
index 00000000..522c1392
--- /dev/null
+++ b/src/lib/lapack/dormrq.f
@@ -0,0 +1,268 @@
+      SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMRQ overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DGERQF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DGERQF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+     $                   MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARFB, DLARFT, DORMR2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = MAX( 1, N )
+      ELSE
+         NQ = N
+         NW = MAX( 1, M )
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+*
+*           Determine the block size.  NB may be at most NBMAX, where
+*           NBMAX is used to define the local array T.
+*
+            NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N,
+     $                               K, -1 ) )
+            LWKOPT = NW*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMRQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+         ELSE
+            MI = M
+         END IF
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'T'
+         ELSE
+            TRANST = 'N'
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i+ib-1) . . . H(i+1) H(i)
+*
+            CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB,
+     $                   A( I, 1 ), LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+               MI = M - K + I + IB - 1
+            ELSE
+*
+*              H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+               NI = N - K + I + IB - 1
+            END IF
+*
+*           Apply H or H'
+*
+            CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+     $                   IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK,
+     $                   LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DORMRQ
+*
+      END
diff --git a/src/lib/lapack/dormrz.f b/src/lib/lapack/dormrz.f
new file mode 100644
index 00000000..9e14acce
--- /dev/null
+++ b/src/lib/lapack/dormrz.f
@@ -0,0 +1,292 @@
+      SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DORMRZ overwrites the general real M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'T':      Q**T * C       C * Q**T
+*
+*  where Q is a real orthogonal matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**T from the Left;
+*          = 'R': apply Q or Q**T from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'T':  Transpose, apply Q**T.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing
+*          the meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          DTZRZF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) DOUBLE PRECISION array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by DTZRZF.
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC,
+     $                   LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARZB, DLARZT, DORMR3, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = MAX( 1, N )
+      ELSE
+         NQ = N
+         NW = MAX( 1, M )
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+     $         ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+            LWKOPT = 1
+*
+*           Determine the block size.  NB may be at most NBMAX, where
+*           NBMAX is used to define the local array T.
+*
+            NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N,
+     $                               K, -1 ) )
+            LWKOPT = NW*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DORMRZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                WORK, IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+            JA = M - L + 1
+         ELSE
+            MI = M
+            IC = 1
+            JA = N - L + 1
+         END IF
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'T'
+         ELSE
+            TRANST = 'N'
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i+ib-1) . . . H(i+1) H(i)
+*
+            CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
+     $                   TAU( I ), T, LDT )
+*
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+     $                   IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
+     $                   LDC, WORK, LDWORK )
+   10    CONTINUE
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DORMRZ
+*
+      END
diff --git a/src/lib/lapack/dpocon.f b/src/lib/lapack/dpocon.f
new file mode 100644
index 00000000..c28af374
--- /dev/null
+++ b/src/lib/lapack/dpocon.f
@@ -0,0 +1,177 @@
+      SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric positive definite matrix using the
+*  Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*          estimate of the 1-norm of inv(A) computed in this routine.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE
+      DOUBLE PRECISION   AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLATRS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the 1-norm of inv(A).
+*
+      KASE = 0
+      NORMIN = 'N'
+   10 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( UPPER ) THEN
+*
+*           Multiply by inv(U').
+*
+            CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+     $                   LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(U).
+*
+            CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(L).
+*
+            CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+            NORMIN = 'Y'
+*
+*           Multiply by inv(L').
+*
+            CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A,
+     $                   LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+         END IF
+*
+*        Multiply by 1/SCALE if doing so will not cause overflow.
+*
+         SCALE = SCALEL*SCALEU
+         IF( SCALE.NE.ONE ) THEN
+            IX = IDAMAX( N, WORK, 1 )
+            IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL DRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DPOCON
+*
+      END
diff --git a/src/lib/lapack/dpotf2.f b/src/lib/lapack/dpotf2.f
new file mode 100644
index 00000000..b7d65e91
--- /dev/null
+++ b/src/lib/lapack/dpotf2.f
@@ -0,0 +1,167 @@
+      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOTF2 computes the Cholesky factorization of a real symmetric
+*  positive definite matrix A.
+*
+*  The factorization has the form
+*     A = U' * U ,  if UPLO = 'U', or
+*     A = L  * L',  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U'*U  or A = L*L'.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*          > 0: if INFO = k, the leading minor of order k is not
+*               positive definite, and the factorization could not be
+*               completed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
+            IF( AJJ.LE.ZERO ) THEN
+               A( J, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            A( J, J ) = AJJ
+*
+*           Compute elements J+1:N of row J.
+*
+            IF( J.LT.N ) THEN
+               CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
+     $                     LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
+               CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Compute the Cholesky factorization A = L*L'.
+*
+         DO 20 J = 1, N
+*
+*           Compute L(J,J) and test for non-positive-definiteness.
+*
+            AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
+     $            LDA )
+            IF( AJJ.LE.ZERO ) THEN
+               A( J, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            A( J, J ) = AJJ
+*
+*           Compute elements J+1:N of column J.
+*
+            IF( J.LT.N ) THEN
+               CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
+     $                     LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
+               CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = J
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of DPOTF2
+*
+      END
diff --git a/src/lib/lapack/dpotrf.f b/src/lib/lapack/dpotrf.f
new file mode 100644
index 00000000..8449df6d
--- /dev/null
+++ b/src/lib/lapack/dpotrf.f
@@ -0,0 +1,183 @@
+      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOTRF computes the Cholesky factorization of a real symmetric
+*  positive definite matrix A.
+*
+*  The factorization has the form
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L  * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  This is the block version of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U**T*U or A = L*L**T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the leading minor of order i is not
+*                positive definite, and the factorization could not be
+*                completed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL DPOTF2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code.
+*
+         IF( UPPER ) THEN
+*
+*           Compute the Cholesky factorization A = U'*U.
+*
+            DO 10 J = 1, N, NB
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               JB = MIN( NB, N-J+1 )
+               CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+     $                     A( 1, J ), LDA, ONE, A( J, J ), LDA )
+               CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute the current block row.
+*
+                  CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
+     $                        J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
+     $                        LDA, ONE, A( J, J+JB ), LDA )
+                  CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+     $                        JB, N-J-JB+1, ONE, A( J, J ), LDA,
+     $                        A( J, J+JB ), LDA )
+               END IF
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               JB = MIN( NB, N-J+1 )
+               CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
+     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+               CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute the current block column.
+*
+                  CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+     $                        J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
+     $                        LDA, ONE, A( J+JB, J ), LDA )
+                  CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+     $                        N-J-JB+1, JB, ONE, A( J, J ), LDA,
+     $                        A( J+JB, J ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of DPOTRF
+*
+      END
diff --git a/src/lib/lapack/dpotrs.f b/src/lib/lapack/dpotrs.f
new file mode 100644
index 00000000..0273655e
--- /dev/null
+++ b/src/lib/lapack/dpotrs.f
@@ -0,0 +1,132 @@
+      SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPOTRS solves a system of linear equations A*X = B with a symmetric
+*  positive definite matrix A using the Cholesky factorization
+*  A = U**T*U or A = L*L**T computed by DPOTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The triangular factor U or L from the Cholesky factorization
+*          A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit, the solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPOTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Solve A*X = B where A = U'*U.
+*
+*        Solve U'*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+      ELSE
+*
+*        Solve A*X = B where A = L*L'.
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+      END IF
+*
+      RETURN
+*
+*     End of DPOTRS
+*
+      END
diff --git a/src/lib/lapack/dpptrf.f b/src/lib/lapack/dpptrf.f
new file mode 100644
index 00000000..a5e2a596
--- /dev/null
+++ b/src/lib/lapack/dpptrf.f
@@ -0,0 +1,177 @@
+      SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DPPTRF computes the Cholesky factorization of a real symmetric
+*  positive definite matrix A stored in packed format.
+*
+*  The factorization has the form
+*     A = U**T * U,  if UPLO = 'U', or
+*     A = L  * L**T,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*          See below for further details.
+*
+*          On exit, if INFO = 0, the triangular factor U or L from the
+*          Cholesky factorization A = U**T*U or A = L*L**T, in the same
+*          storage format as A.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the leading minor of order i is not
+*                positive definite, and the factorization could not be
+*                completed.
+*
+*  Further Details
+*  ======= =======
+*
+*  The packed storage scheme is illustrated by the following example
+*  when N = 4, UPLO = 'U':
+*
+*  Two-dimensional storage of the symmetric matrix A:
+*
+*     a11 a12 a13 a14
+*         a22 a23 a24
+*             a33 a34     (aij = aji)
+*                 a44
+*
+*  Packed storage of the upper triangle of A:
+*
+*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JC, JJ
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSPR, DTPSV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DPPTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         JJ = 0
+         DO 10 J = 1, N
+            JC = JJ + 1
+            JJ = JJ + J
+*
+*           Compute elements 1:J-1 of column J.
+*
+            IF( J.GT.1 )
+     $         CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
+     $                     AP( JC ), 1 )
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
+            IF( AJJ.LE.ZERO ) THEN
+               AP( JJ ) = AJJ
+               GO TO 30
+            END IF
+            AP( JJ ) = SQRT( AJJ )
+   10    CONTINUE
+      ELSE
+*
+*        Compute the Cholesky factorization A = L*L'.
+*
+         JJ = 1
+         DO 20 J = 1, N
+*
+*           Compute L(J,J) and test for non-positive-definiteness.
+*
+            AJJ = AP( JJ )
+            IF( AJJ.LE.ZERO ) THEN
+               AP( JJ ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            AP( JJ ) = AJJ
+*
+*           Compute elements J+1:N of column J and update the trailing
+*           submatrix.
+*
+            IF( J.LT.N ) THEN
+               CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+               CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
+     $                    AP( JJ+N-J+1 ) )
+               JJ = JJ + N - J + 1
+            END IF
+   20    CONTINUE
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = J
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of DPPTRF
+*
+      END
diff --git a/src/lib/lapack/drscl.f b/src/lib/lapack/drscl.f
new file mode 100644
index 00000000..a13e96d8
--- /dev/null
+++ b/src/lib/lapack/drscl.f
@@ -0,0 +1,114 @@
+      SUBROUTINE DRSCL( N, SA, SX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   SA
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   SX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DRSCL multiplies an n-element real vector x by the real scalar 1/a.
+*  This is done without overflow or underflow as long as
+*  the final result x/a does not overflow or underflow.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of components of the vector x.
+*
+*  SA      (input) DOUBLE PRECISION
+*          The scalar a which is used to divide each component of x.
+*          SA must be >= 0, or the subroutine will divide by zero.
+*
+*  SX      (input/output) DOUBLE PRECISION array, dimension
+*                         (1+(N-1)*abs(INCX))
+*          The n-element vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of the vector SX.
+*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Initialize the denominator to SA and the numerator to 1.
+*
+      CDEN = SA
+      CNUM = ONE
+*
+   10 CONTINUE
+      CDEN1 = CDEN*SMLNUM
+      CNUM1 = CNUM / BIGNUM
+      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
+*
+*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
+*
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CDEN = CDEN1
+      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
+*
+*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
+*
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CNUM = CNUM1
+      ELSE
+*
+*        Multiply X by CNUM / CDEN and return.
+*
+         MUL = CNUM / CDEN
+         DONE = .TRUE.
+      END IF
+*
+*     Scale the vector X by MUL
+*
+      CALL DSCAL( N, MUL, SX, INCX )
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of DRSCL
+*
+      END
diff --git a/src/lib/lapack/dspev.f b/src/lib/lapack/dspev.f
new file mode 100644
index 00000000..64582c99
--- /dev/null
+++ b/src/lib/lapack/dspev.f
@@ -0,0 +1,187 @@
+      SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, UPLO
+      INTEGER            INFO, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
+*  real symmetric matrix A in packed storage.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, AP is overwritten by values generated during the
+*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal
+*          and first superdiagonal of the tridiagonal matrix T overwrite
+*          the corresponding elements of A, and if UPLO = 'L', the
+*          diagonal and first subdiagonal of T overwrite the
+*          corresponding elements of A.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+*          eigenvectors of the matrix A, with the i-th column of Z
+*          holding the eigenvector associated with W(i).
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = i, the algorithm failed to converge; i
+*                off-diagonal elements of an intermediate tridiagonal
+*                form did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANSP
+      EXTERNAL           LSAME, DLAMCH, DLANSP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+     $          THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPEV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = AP( 1 )
+         IF( WANTZ )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+      END IF
+*
+*     Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     DOPGTR to generate the orthogonal matrix, then call DSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         INDWRK = INDTAU + N
+         CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+     $                WORK( INDWRK ), IINFO )
+         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of DSPEV
+*
+      END
diff --git a/src/lib/lapack/dspgst.f b/src/lib/lapack/dspgst.f
new file mode 100644
index 00000000..8e121a94
--- /dev/null
+++ b/src/lib/lapack/dspgst.f
@@ -0,0 +1,208 @@
+      SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, ITYPE, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), BP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPGST reduces a real symmetric-definite generalized eigenproblem
+*  to standard form, using packed storage.
+*
+*  If ITYPE = 1, the problem is A*x = lambda*B*x,
+*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+*  B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
+*          = 2 or 3: compute U*A*U**T or L**T*A*L.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored and B is factored as
+*                  U**T*U;
+*          = 'L':  Lower triangle of A is stored and B is factored as
+*                  L*L**T.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, if INFO = 0, the transformed matrix, stored in the
+*          same format as A.
+*
+*  BP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          The triangular factor from the Cholesky factorization of B,
+*          stored in the same format as A, as returned by DPPTRF.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, HALF
+      PARAMETER          ( ONE = 1.0D0, HALF = 0.5D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, J1, J1J1, JJ, K, K1, K1K1, KK
+      DOUBLE PRECISION   AJJ, AKK, BJJ, BKK, CT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPGST', -INFO )
+         RETURN
+      END IF
+*
+      IF( ITYPE.EQ.1 ) THEN
+         IF( UPPER ) THEN
+*
+*           Compute inv(U')*A*inv(U)
+*
+*           J1 and JJ are the indices of A(1,j) and A(j,j)
+*
+            JJ = 0
+            DO 10 J = 1, N
+               J1 = JJ + 1
+               JJ = JJ + J
+*
+*              Compute the j-th column of the upper triangle of A
+*
+               BJJ = BP( JJ )
+               CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
+     $                     AP( J1 ), 1 )
+               CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
+     $                     AP( J1 ), 1 )
+               CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+               AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ),
+     $                    1 ) ) / BJJ
+   10       CONTINUE
+         ELSE
+*
+*           Compute inv(L)*A*inv(L')
+*
+*           KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
+*
+            KK = 1
+            DO 20 K = 1, N
+               K1K1 = KK + N - K + 1
+*
+*              Update the lower triangle of A(k:n,k:n)
+*
+               AKK = AP( KK )
+               BKK = BP( KK )
+               AKK = AKK / BKK**2
+               AP( KK ) = AKK
+               IF( K.LT.N ) THEN
+                  CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+                  CT = -HALF*AKK
+                  CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
+     $                        BP( KK+1 ), 1, AP( K1K1 ) )
+                  CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+                  CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
+     $                        BP( K1K1 ), AP( KK+1 ), 1 )
+               END IF
+               KK = K1K1
+   20       CONTINUE
+         END IF
+      ELSE
+         IF( UPPER ) THEN
+*
+*           Compute U*A*U'
+*
+*           K1 and KK are the indices of A(1,k) and A(k,k)
+*
+            KK = 0
+            DO 30 K = 1, N
+               K1 = KK + 1
+               KK = KK + K
+*
+*              Update the upper triangle of A(1:k,1:k)
+*
+               AKK = AP( KK )
+               BKK = BP( KK )
+               CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+     $                     AP( K1 ), 1 )
+               CT = HALF*AKK
+               CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
+     $                     AP )
+               CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+               CALL DSCAL( K-1, BKK, AP( K1 ), 1 )
+               AP( KK ) = AKK*BKK**2
+   30       CONTINUE
+         ELSE
+*
+*           Compute L'*A*L
+*
+*           JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
+*
+            JJ = 1
+            DO 40 J = 1, N
+               J1J1 = JJ + N - J + 1
+*
+*              Compute the j-th column of the lower triangle of A
+*
+               AJJ = AP( JJ )
+               BJJ = BP( JJ )
+               AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1,
+     $                    BP( JJ+1 ), 1 )
+               CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+               CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
+     $                     ONE, AP( JJ+1 ), 1 )
+               CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
+     $                     BP( JJ ), AP( JJ ), 1 )
+               JJ = J1J1
+   40       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of DSPGST
+*
+      END
diff --git a/src/lib/lapack/dspgv.f b/src/lib/lapack/dspgv.f
new file mode 100644
index 00000000..737a1ee3
--- /dev/null
+++ b/src/lib/lapack/dspgv.f
@@ -0,0 +1,195 @@
+      SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+     $                  INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, UPLO
+      INTEGER            INFO, ITYPE, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), BP( * ), W( * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPGV computes all the eigenvalues and, optionally, the eigenvectors
+*  of a real generalized symmetric-definite eigenproblem, of the form
+*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.
+*  Here A and B are assumed to be symmetric, stored in packed format,
+*  and B is also positive definite.
+*
+*  Arguments
+*  =========
+*
+*  ITYPE   (input) INTEGER
+*          Specifies the problem type to be solved:
+*          = 1:  A*x = (lambda)*B*x
+*          = 2:  A*B*x = (lambda)*x
+*          = 3:  B*A*x = (lambda)*x
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangles of A and B are stored;
+*          = 'L':  Lower triangles of A and B are stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension
+*                            (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the contents of AP are destroyed.
+*
+*  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          B, packed columnwise in a linear array.  The j-th column of B
+*          is stored in the array BP as follows:
+*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+*          On exit, the triangular factor U or L from the Cholesky
+*          factorization B = U**T*U or B = L*L**T, in the same storage
+*          format as B.
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)
+*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+*          eigenvectors.  The eigenvectors are normalized as follows:
+*          if ITYPE = 1 or 2, Z**T*B*Z = I;
+*          if ITYPE = 3, Z**T*inv(B)*Z = I.
+*          If JOBZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          JOBZ = 'V', LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  DPPTRF or DSPEV returned an error code:
+*             <= N:  if INFO = i, DSPEV failed to converge;
+*                    i off-diagonal elements of an intermediate
+*                    tridiagonal form did not converge to zero.
+*             > N:   if INFO = n + i, for 1 <= i <= n, then the leading
+*                    minor of order i of B is not positive definite.
+*                    The factorization of B could not be completed and
+*                    no eigenvalues or eigenvectors were computed.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            UPPER, WANTZ
+      CHARACTER          TRANS
+      INTEGER            J, NEIG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      UPPER = LSAME( UPLO, 'U' )
+*
+      INFO = 0
+      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPGV ', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form a Cholesky factorization of B.
+*
+      CALL DPPTRF( UPLO, N, BP, INFO )
+      IF( INFO.NE.0 ) THEN
+         INFO = N + INFO
+         RETURN
+      END IF
+*
+*     Transform problem to standard eigenvalue problem and solve.
+*
+      CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+      CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+      IF( WANTZ ) THEN
+*
+*        Backtransform eigenvectors to the original problem.
+*
+         NEIG = N
+         IF( INFO.GT.0 )
+     $      NEIG = INFO - 1
+         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'N'
+            ELSE
+               TRANS = 'T'
+            END IF
+*
+            DO 10 J = 1, NEIG
+               CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   10       CONTINUE
+*
+         ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*           For B*A*x=(lambda)*x;
+*           backtransform eigenvectors: x = L*y or U'*y
+*
+            IF( UPPER ) THEN
+               TRANS = 'T'
+            ELSE
+               TRANS = 'N'
+            END IF
+*
+            DO 20 J = 1, NEIG
+               CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+     $                     1 )
+   20       CONTINUE
+         END IF
+      END IF
+      RETURN
+*
+*     End of DSPGV
+*
+      END
diff --git a/src/lib/lapack/dsptrd.f b/src/lib/lapack/dsptrd.f
new file mode 100644
index 00000000..6d3390e3
--- /dev/null
+++ b/src/lib/lapack/dsptrd.f
@@ -0,0 +1,228 @@
+      SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   AP( * ), D( * ), E( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPTRD reduces a real symmetric matrix A stored in packed form to
+*  symmetric tridiagonal form T by an orthogonal similarity
+*  transformation: Q**T * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
+*          of A are overwritten by the corresponding elements of the
+*          tridiagonal matrix T, and the elements above the first
+*          superdiagonal, with the array TAU, represent the orthogonal
+*          matrix Q as a product of elementary reflectors; if UPLO
+*          = 'L', the diagonal and first subdiagonal of A are over-
+*          written by the corresponding elements of the tridiagonal
+*          matrix T, and the elements below the first subdiagonal, with
+*          the array TAU, represent the orthogonal matrix Q as a product
+*          of elementary reflectors. See Further Details.
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n-1) . . . H(2) H(1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
+*  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(n-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
+*  overwriting A(i+2:n,i), and tau is stored in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO, HALF
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0,
+     $                   HALF = 1.0D0 / 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, I1, I1I1, II
+      DOUBLE PRECISION   ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPTRD', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Reduce the upper triangle of A.
+*        I1 is the index in AP of A(1,I+1).
+*
+         I1 = N*( N-1 ) / 2 + 1
+         DO 10 I = N - 1, 1, -1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(1:i-1,i+1)
+*
+            CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
+            E( I ) = AP( I1+I-1 )
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(1:i,1:i)
+*
+               AP( I1+I-1 ) = ONE
+*
+*              Compute  y := tau * A * v  storing y in TAU(1:i)
+*
+               CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+     $                     1 )
+*
+*              Compute  w := y - 1/2 * tau * (y'*v) * v
+*
+               ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
+               CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
+*
+               AP( I1+I-1 ) = E( I )
+            END IF
+            D( I+1 ) = AP( I1+I )
+            TAU( I ) = TAUI
+            I1 = I1 - I
+   10    CONTINUE
+         D( 1 ) = AP( 1 )
+      ELSE
+*
+*        Reduce the lower triangle of A. II is the index in AP of
+*        A(i,i) and I1I1 is the index of A(i+1,i+1).
+*
+         II = 1
+         DO 20 I = 1, N - 1
+            I1I1 = II + N - I + 1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(i+2:n,i)
+*
+            CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
+            E( I ) = AP( II+1 )
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+               AP( II+1 ) = ONE
+*
+*              Compute  y := tau * A * v  storing y in TAU(i:n-1)
+*
+               CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
+     $                     ZERO, TAU( I ), 1 )
+*
+*              Compute  w := y - 1/2 * tau * (y'*v) * v
+*
+               ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ),
+     $                 1 )
+               CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
+     $                     AP( I1I1 ) )
+*
+               AP( II+1 ) = E( I )
+            END IF
+            D( I ) = AP( II )
+            TAU( I ) = TAUI
+            II = I1I1
+   20    CONTINUE
+         D( N ) = AP( II )
+      END IF
+*
+      RETURN
+*
+*     End of DSPTRD
+*
+      END
diff --git a/src/lib/lapack/dsptrf.f b/src/lib/lapack/dsptrf.f
new file mode 100644
index 00000000..8b8a9185
--- /dev/null
+++ b/src/lib/lapack/dsptrf.f
@@ -0,0 +1,547 @@
+      SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   AP( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSPTRF computes the factorization of a real symmetric matrix A stored
+*  in packed format using the Bunch-Kaufman diagonal pivoting method:
+*
+*     A = U*D*U**T  or  A = L*D*L**T
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is symmetric and block diagonal with
+*  1-by-1 and 2-by-2 diagonal blocks.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+*          On entry, the upper or lower triangle of the symmetric matrix
+*          A, packed columnwise in a linear array.  The j-th column of A
+*          is stored in the array AP as follows:
+*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L, stored as a packed triangular
+*          matrix overwriting A (see below for further details).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
+*               has been completed, but the block diagonal matrix D is
+*               exactly singular, and division by zero will occur if it
+*               is used to solve a system of equations.
+*
+*  Further Details
+*  ===============
+*
+*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services
+*         Company
+*
+*  If UPLO = 'U', then A = U*D*U', where
+*     U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    v    0   )   k-s
+*     U(k) =  (   0    I    0   )   s
+*             (   0    0    I   )   n-k
+*                k-s   s   n-k
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*  and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+*  If UPLO = 'L', then A = L*D*L', where
+*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    0     0   )  k-1
+*     L(k) =  (   0    I     0   )  s
+*             (   0    v     I   )  n-k-s+1
+*                k-1   s  n-k-s+1
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+     $                   KSTEP, KX, NPP
+      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+     $                   ROWMAX, T, WK, WKM1, WKP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      EXTERNAL           LSAME, IDAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSPR, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSPTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize ALPHA for use in choosing pivot block size.
+*
+      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A as U*D*U' using the upper triangle of A
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2
+*
+         K = N
+         KC = ( N-1 )*N / 2 + 1
+   10    CONTINUE
+         KNC = KC
+*
+*        If K < 1, exit from loop
+*
+         IF( K.LT.1 )
+     $      GO TO 110
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( AP( KC+K-1 ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.GT.1 ) THEN
+            IMAX = IDAMAX( K-1, AP( KC ), 1 )
+            COLMAX = ABS( AP( KC+IMAX-1 ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+*           Column K is zero: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               ROWMAX = ZERO
+               JMAX = IMAX
+               KX = IMAX*( IMAX+1 ) / 2 + IMAX
+               DO 20 J = IMAX + 1, K
+                  IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = ABS( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + J
+   20          CONTINUE
+               KPC = ( IMAX-1 )*IMAX / 2 + 1
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+               ELSE
+*
+*                 interchange rows and columns K-1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K - KSTEP + 1
+            IF( KSTEP.EQ.2 )
+     $         KNC = KNC - K + 1
+            IF( KP.NE.KK ) THEN
+*
+*              Interchange rows and columns KK and KP in the leading
+*              submatrix A(1:k,1:k)
+*
+               CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
+               KX = KPC + KP - 1
+               DO 30 J = KP + 1, KK - 1
+                  KX = KX + J - 1
+                  T = AP( KNC+J-1 )
+                  AP( KNC+J-1 ) = AP( KX )
+                  AP( KX ) = T
+   30          CONTINUE
+               T = AP( KNC+KK-1 )
+               AP( KNC+KK-1 ) = AP( KPC+KP-1 )
+               AP( KPC+KP-1 ) = T
+               IF( KSTEP.EQ.2 ) THEN
+                  T = AP( KC+K-2 )
+                  AP( KC+K-2 ) = AP( KC+KP-1 )
+                  AP( KC+KP-1 ) = T
+               END IF
+            END IF
+*
+*           Update the leading submatrix
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column k now holds
+*
+*              W(k) = U(k)*D(k)
+*
+*              where U(k) is the k-th column of U
+*
+*              Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+*              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+               R1 = ONE / AP( KC+K-1 )
+               CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+*              Store U(k) in column k
+*
+               CALL DSCAL( K-1, R1, AP( KC ), 1 )
+            ELSE
+*
+*              2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
+*              of U
+*
+*              Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+*              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+*                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+               IF( K.GT.2 ) THEN
+*
+                  D12 = AP( K-1+( K-1 )*K / 2 )
+                  D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
+                  D11 = AP( K+( K-1 )*K / 2 ) / D12
+                  T = ONE / ( D11*D22-ONE )
+                  D12 = T / D12
+*
+                  DO 50 J = K - 2, 1, -1
+                     WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
+     $                      AP( J+( K-1 )*K / 2 ) )
+                     WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
+     $                    AP( J+( K-2 )*( K-1 ) / 2 ) )
+                     DO 40 I = J, 1, -1
+                        AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
+     $                     AP( I+( K-1 )*K / 2 )*WK -
+     $                     AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
+   40                CONTINUE
+                     AP( J+( K-1 )*K / 2 ) = WK
+                     AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
+   50             CONTINUE
+*
+               END IF
+*
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K-1 ) = -KP
+         END IF
+*
+*        Decrease K and return to the start of the main loop
+*
+         K = K - KSTEP
+         KC = KNC - K
+         GO TO 10
+*
+      ELSE
+*
+*        Factorize A as L*D*L' using the lower triangle of A
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2
+*
+         K = 1
+         KC = 1
+         NPP = N*( N+1 ) / 2
+   60    CONTINUE
+         KNC = KC
+*
+*        If K > N, exit from loop
+*
+         IF( K.GT.N )
+     $      GO TO 110
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( AP( KC ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.LT.N ) THEN
+            IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 )
+            COLMAX = ABS( AP( KC+IMAX-K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+*           Column K is zero: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               ROWMAX = ZERO
+               KX = KC + IMAX - K
+               DO 70 J = K, IMAX - 1
+                  IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+                     ROWMAX = ABS( AP( KX ) )
+                     JMAX = J
+                  END IF
+                  KX = KX + N - J
+   70          CONTINUE
+               KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+               ELSE
+*
+*                 interchange rows and columns K+1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K + KSTEP - 1
+            IF( KSTEP.EQ.2 )
+     $         KNC = KNC + N - K + 1
+            IF( KP.NE.KK ) THEN
+*
+*              Interchange rows and columns KK and KP in the trailing
+*              submatrix A(k:n,k:n)
+*
+               IF( KP.LT.N )
+     $            CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
+     $                        1 )
+               KX = KNC + KP - KK
+               DO 80 J = KK + 1, KP - 1
+                  KX = KX + N - J + 1
+                  T = AP( KNC+J-KK )
+                  AP( KNC+J-KK ) = AP( KX )
+                  AP( KX ) = T
+   80          CONTINUE
+               T = AP( KNC )
+               AP( KNC ) = AP( KPC )
+               AP( KPC ) = T
+               IF( KSTEP.EQ.2 ) THEN
+                  T = AP( KC+1 )
+                  AP( KC+1 ) = AP( KC+KP-K )
+                  AP( KC+KP-K ) = T
+               END IF
+            END IF
+*
+*           Update the trailing submatrix
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column k now holds
+*
+*              W(k) = L(k)*D(k)
+*
+*              where L(k) is the k-th column of L
+*
+               IF( K.LT.N ) THEN
+*
+*                 Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+*                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+                  R1 = ONE / AP( KC )
+                  CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+     $                       AP( KC+N-K+1 ) )
+*
+*                 Store L(k) in column K
+*
+                  CALL DSCAL( N-K, R1, AP( KC+1 ), 1 )
+               END IF
+            ELSE
+*
+*              2-by-2 pivot block D(k): columns K and K+1 now hold
+*
+*              ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+*              where L(k) and L(k+1) are the k-th and (k+1)-th columns
+*              of L
+*
+               IF( K.LT.N-1 ) THEN
+*
+*                 Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+*                 A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
+*                    = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
+*
+                  D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
+                  D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
+                  D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
+                  T = ONE / ( D11*D22-ONE )
+                  D21 = T / D21
+*
+                  DO 100 J = K + 2, N
+                     WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
+     $                    AP( J+K*( 2*N-K-1 ) / 2 ) )
+                     WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
+     $                      AP( J+( K-1 )*( 2*N-K ) / 2 ) )
+*
+                     DO 90 I = J, N
+                        AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
+     $                     ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
+     $                     2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
+   90                CONTINUE
+*
+                     AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
+                     AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
+*
+  100             CONTINUE
+               END IF
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K+1 ) = -KP
+         END IF
+*
+*        Increase K and return to the start of the main loop
+*
+         K = K + KSTEP
+         KC = KNC + N - K + 2
+         GO TO 60
+*
+      END IF
+*
+  110 CONTINUE
+      RETURN
+*
+*     End of DSPTRF
+*
+      END
diff --git a/src/lib/lapack/dsteqr.f b/src/lib/lapack/dsteqr.f
new file mode 100644
index 00000000..0afd7957
--- /dev/null
+++ b/src/lib/lapack/dsteqr.f
@@ -0,0 +1,500 @@
+      SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ
+      INTEGER            INFO, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the implicit QL or QR method.
+*  The eigenvectors of a full or band symmetric matrix can also be found
+*  if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
+*  tridiagonal form.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvalues and eigenvectors of the original
+*                  symmetric matrix.  On entry, Z must contain the
+*                  orthogonal matrix used to reduce the original matrix
+*                  to tridiagonal form.
+*          = 'I':  Compute eigenvalues and eigenvectors of the
+*                  tridiagonal matrix.  Z is initialized to the identity
+*                  matrix.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the diagonal elements of the tridiagonal matrix.
+*          On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+*          On entry, if  COMPZ = 'V', then Z contains the orthogonal
+*          matrix used in the reduction to tridiagonal form.
+*          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the
+*          orthonormal eigenvectors of the original symmetric matrix,
+*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+*          of the symmetric tridiagonal matrix.
+*          If COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          eigenvectors are desired, then  LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
+*          If COMPZ = 'N', then WORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  the algorithm has failed to find all the eigenvalues in
+*                a total of 30*N iterations; if INFO = i, then i
+*                elements of E have not converged to zero; on exit, D
+*                and E contain the elements of a symmetric tridiagonal
+*                matrix which is orthogonally similar to the original
+*                matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   THREE = 3.0D0 )
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
+     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
+     $                   NM1, NMAXIT
+      DOUBLE PRECISION   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
+      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
+     $                   DLASRT, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.EQ.2 )
+     $      Z( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Determine the unit roundoff and over/underflow thresholds.
+*
+      EPS = DLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      SSFMAX = SQRT( SAFMAX ) / THREE
+      SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+*     Compute the eigenvalues and eigenvectors of the tridiagonal
+*     matrix.
+*
+      IF( ICOMPZ.EQ.2 )
+     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+      NMAXIT = N*MAXIT
+      JTOT = 0
+*
+*     Determine where the matrix splits and choose QL or QR iteration
+*     for each block, according to whether top or bottom diagonal
+*     element is smaller.
+*
+      L1 = 1
+      NM1 = N - 1
+*
+   10 CONTINUE
+      IF( L1.GT.N )
+     $   GO TO 160
+      IF( L1.GT.1 )
+     $   E( L1-1 ) = ZERO
+      IF( L1.LE.NM1 ) THEN
+         DO 20 M = L1, NM1
+            TST = ABS( E( M ) )
+            IF( TST.EQ.ZERO )
+     $         GO TO 30
+            IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+     $          1 ) ) ) )*EPS ) THEN
+               E( M ) = ZERO
+               GO TO 30
+            END IF
+   20    CONTINUE
+      END IF
+      M = N
+*
+   30 CONTINUE
+      L = L1
+      LSV = L
+      LEND = M
+      LENDSV = LEND
+      L1 = M + 1
+      IF( LEND.EQ.L )
+     $   GO TO 10
+*
+*     Scale submatrix in rows and columns L to LEND
+*
+      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
+      ISCALE = 0
+      IF( ANORM.EQ.ZERO )
+     $   GO TO 10
+      IF( ANORM.GT.SSFMAX ) THEN
+         ISCALE = 1
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+     $                INFO )
+      END IF
+*
+*     Choose between QL and QR iteration
+*
+      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+         LEND = LSV
+         L = LENDSV
+      END IF
+*
+      IF( LEND.GT.L ) THEN
+*
+*        QL Iteration
+*
+*        Look for small subdiagonal element.
+*
+   40    CONTINUE
+         IF( L.NE.LEND ) THEN
+            LENDM1 = LEND - 1
+            DO 50 M = L, LENDM1
+               TST = ABS( E( M ) )**2
+               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
+     $             SAFMIN )GO TO 60
+   50       CONTINUE
+         END IF
+*
+         M = LEND
+*
+   60    CONTINUE
+         IF( M.LT.LEND )
+     $      E( M ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 80
+*
+*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L+1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+               WORK( L ) = C
+               WORK( N-1+L ) = S
+               CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
+            ELSE
+               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
+            END IF
+            D( L ) = RT1
+            D( L+1 ) = RT2
+            E( L ) = ZERO
+            L = L + 2
+            IF( L.LE.LEND )
+     $         GO TO 40
+            GO TO 140
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 140
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
+         R = DLAPY2( G, ONE )
+         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
+*
+         S = ONE
+         C = ONE
+         P = ZERO
+*
+*        Inner loop
+*
+         MM1 = M - 1
+         DO 70 I = MM1, L, -1
+            F = S*E( I )
+            B = C*E( I )
+            CALL DLARTG( G, F, C, S, R )
+            IF( I.NE.M-1 )
+     $         E( I+1 ) = R
+            G = D( I+1 ) - P
+            R = ( D( I )-G )*S + TWO*C*B
+            P = S*R
+            D( I+1 ) = G + P
+            G = C*R - B
+*
+*           If eigenvectors are desired, then save rotations.
+*
+            IF( ICOMPZ.GT.0 ) THEN
+               WORK( I ) = C
+               WORK( N-1+I ) = -S
+            END IF
+*
+   70    CONTINUE
+*
+*        If eigenvectors are desired, then apply saved rotations.
+*
+         IF( ICOMPZ.GT.0 ) THEN
+            MM = M - L + 1
+            CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
+     $                  Z( 1, L ), LDZ )
+         END IF
+*
+         D( L ) = D( L ) - P
+         E( L ) = G
+         GO TO 40
+*
+*        Eigenvalue found.
+*
+   80    CONTINUE
+         D( L ) = P
+*
+         L = L + 1
+         IF( L.LE.LEND )
+     $      GO TO 40
+         GO TO 140
+*
+      ELSE
+*
+*        QR Iteration
+*
+*        Look for small superdiagonal element.
+*
+   90    CONTINUE
+         IF( L.NE.LEND ) THEN
+            LENDP1 = LEND + 1
+            DO 100 M = L, LENDP1, -1
+               TST = ABS( E( M-1 ) )**2
+               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
+     $             SAFMIN )GO TO 110
+  100       CONTINUE
+         END IF
+*
+         M = LEND
+*
+  110    CONTINUE
+         IF( M.GT.LEND )
+     $      E( M-1 ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 130
+*
+*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L-1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+               WORK( M ) = C
+               WORK( N-1+M ) = S
+               CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+            ELSE
+               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
+            END IF
+            D( L-1 ) = RT1
+            D( L ) = RT2
+            E( L-1 ) = ZERO
+            L = L - 2
+            IF( L.GE.LEND )
+     $         GO TO 90
+            GO TO 140
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 140
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
+         R = DLAPY2( G, ONE )
+         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
+*
+         S = ONE
+         C = ONE
+         P = ZERO
+*
+*        Inner loop
+*
+         LM1 = L - 1
+         DO 120 I = M, LM1
+            F = S*E( I )
+            B = C*E( I )
+            CALL DLARTG( G, F, C, S, R )
+            IF( I.NE.M )
+     $         E( I-1 ) = R
+            G = D( I ) - P
+            R = ( D( I+1 )-G )*S + TWO*C*B
+            P = S*R
+            D( I ) = G + P
+            G = C*R - B
+*
+*           If eigenvectors are desired, then save rotations.
+*
+            IF( ICOMPZ.GT.0 ) THEN
+               WORK( I ) = C
+               WORK( N-1+I ) = S
+            END IF
+*
+  120    CONTINUE
+*
+*        If eigenvectors are desired, then apply saved rotations.
+*
+         IF( ICOMPZ.GT.0 ) THEN
+            MM = L - M + 1
+            CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
+     $                  Z( 1, M ), LDZ )
+         END IF
+*
+         D( L ) = D( L ) - P
+         E( LM1 ) = G
+         GO TO 90
+*
+*        Eigenvalue found.
+*
+  130    CONTINUE
+         D( L ) = P
+*
+         L = L - 1
+         IF( L.GE.LEND )
+     $      GO TO 90
+         GO TO 140
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+  140 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      ELSE IF( ISCALE.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      END IF
+*
+*     Check for no convergence to an eigenvalue after a total
+*     of N*MAXIT iterations.
+*
+      IF( JTOT.LT.NMAXIT )
+     $   GO TO 10
+      DO 150 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  150 CONTINUE
+      GO TO 190
+*
+*     Order eigenvalues and eigenvectors.
+*
+  160 CONTINUE
+      IF( ICOMPZ.EQ.0 ) THEN
+*
+*        Use Quick Sort
+*
+         CALL DLASRT( 'I', N, D, INFO )
+*
+      ELSE
+*
+*        Use Selection Sort to minimize swaps of eigenvectors
+*
+         DO 180 II = 2, N
+            I = II - 1
+            K = I
+            P = D( I )
+            DO 170 J = II, N
+               IF( D( J ).LT.P ) THEN
+                  K = J
+                  P = D( J )
+               END IF
+  170       CONTINUE
+            IF( K.NE.I ) THEN
+               D( K ) = D( I )
+               D( I ) = P
+               CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+            END IF
+  180    CONTINUE
+      END IF
+*
+  190 CONTINUE
+      RETURN
+*
+*     End of DSTEQR
+*
+      END
diff --git a/src/lib/lapack/dsterf.f b/src/lib/lapack/dsterf.f
new file mode 100644
index 00000000..c17ea23a
--- /dev/null
+++ b/src/lib/lapack/dsterf.f
@@ -0,0 +1,364 @@
+      SUBROUTINE DSTERF( N, D, E, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
+*  using the Pal-Walker-Kahan variant of the QL or QR algorithm.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the tridiagonal matrix.
+*          On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix.
+*          On exit, E has been destroyed.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  the algorithm failed to find all of the eigenvalues in
+*                a total of 30*N iterations; if INFO = i, then i
+*                elements of E have not converged to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   THREE = 3.0D0 )
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
+     $                   NMAXIT
+      DOUBLE PRECISION   ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
+     $                   OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
+     $                   SIGMA, SSFMAX, SSFMIN
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
+      EXTERNAL           DLAMCH, DLANST, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAE2, DLASCL, DLASRT, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.LT.0 ) THEN
+         INFO = -1
+         CALL XERBLA( 'DSTERF', -INFO )
+         RETURN
+      END IF
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Determine the unit roundoff for this environment.
+*
+      EPS = DLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      SSFMAX = SQRT( SAFMAX ) / THREE
+      SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+*     Compute the eigenvalues of the tridiagonal matrix.
+*
+      NMAXIT = N*MAXIT
+      SIGMA = ZERO
+      JTOT = 0
+*
+*     Determine where the matrix splits and choose QL or QR iteration
+*     for each block, according to whether top or bottom diagonal
+*     element is smaller.
+*
+      L1 = 1
+*
+   10 CONTINUE
+      IF( L1.GT.N )
+     $   GO TO 170
+      IF( L1.GT.1 )
+     $   E( L1-1 ) = ZERO
+      DO 20 M = L1, N - 1
+         IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+     $       1 ) ) ) )*EPS ) THEN
+            E( M ) = ZERO
+            GO TO 30
+         END IF
+   20 CONTINUE
+      M = N
+*
+   30 CONTINUE
+      L = L1
+      LSV = L
+      LEND = M
+      LENDSV = LEND
+      L1 = M + 1
+      IF( LEND.EQ.L )
+     $   GO TO 10
+*
+*     Scale submatrix in rows and columns L to LEND
+*
+      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
+      ISCALE = 0
+      IF( ANORM.GT.SSFMAX ) THEN
+         ISCALE = 1
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+     $                INFO )
+      END IF
+*
+      DO 40 I = L, LEND - 1
+         E( I ) = E( I )**2
+   40 CONTINUE
+*
+*     Choose between QL and QR iteration
+*
+      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+         LEND = LSV
+         L = LENDSV
+      END IF
+*
+      IF( LEND.GE.L ) THEN
+*
+*        QL Iteration
+*
+*        Look for small subdiagonal element.
+*
+   50    CONTINUE
+         IF( L.NE.LEND ) THEN
+            DO 60 M = L, LEND - 1
+               IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
+     $            GO TO 70
+   60       CONTINUE
+         END IF
+         M = LEND
+*
+   70    CONTINUE
+         IF( M.LT.LEND )
+     $      E( M ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 90
+*
+*        If remaining matrix is 2 by 2, use DLAE2 to compute its
+*        eigenvalues.
+*
+         IF( M.EQ.L+1 ) THEN
+            RTE = SQRT( E( L ) )
+            CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
+            D( L ) = RT1
+            D( L+1 ) = RT2
+            E( L ) = ZERO
+            L = L + 2
+            IF( L.LE.LEND )
+     $         GO TO 50
+            GO TO 150
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 150
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         RTE = SQRT( E( L ) )
+         SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
+         R = DLAPY2( SIGMA, ONE )
+         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+         C = ONE
+         S = ZERO
+         GAMMA = D( M ) - SIGMA
+         P = GAMMA*GAMMA
+*
+*        Inner loop
+*
+         DO 80 I = M - 1, L, -1
+            BB = E( I )
+            R = P + BB
+            IF( I.NE.M-1 )
+     $         E( I+1 ) = S*R
+            OLDC = C
+            C = P / R
+            S = BB / R
+            OLDGAM = GAMMA
+            ALPHA = D( I )
+            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+            D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
+            IF( C.NE.ZERO ) THEN
+               P = ( GAMMA*GAMMA ) / C
+            ELSE
+               P = OLDC*BB
+            END IF
+   80    CONTINUE
+*
+         E( L ) = S*P
+         D( L ) = SIGMA + GAMMA
+         GO TO 50
+*
+*        Eigenvalue found.
+*
+   90    CONTINUE
+         D( L ) = P
+*
+         L = L + 1
+         IF( L.LE.LEND )
+     $      GO TO 50
+         GO TO 150
+*
+      ELSE
+*
+*        QR Iteration
+*
+*        Look for small superdiagonal element.
+*
+  100    CONTINUE
+         DO 110 M = L, LEND + 1, -1
+            IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
+     $         GO TO 120
+  110    CONTINUE
+         M = LEND
+*
+  120    CONTINUE
+         IF( M.GT.LEND )
+     $      E( M-1 ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 140
+*
+*        If remaining matrix is 2 by 2, use DLAE2 to compute its
+*        eigenvalues.
+*
+         IF( M.EQ.L-1 ) THEN
+            RTE = SQRT( E( L-1 ) )
+            CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
+            D( L ) = RT1
+            D( L-1 ) = RT2
+            E( L-1 ) = ZERO
+            L = L - 2
+            IF( L.GE.LEND )
+     $         GO TO 100
+            GO TO 150
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 150
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         RTE = SQRT( E( L-1 ) )
+         SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
+         R = DLAPY2( SIGMA, ONE )
+         SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+         C = ONE
+         S = ZERO
+         GAMMA = D( M ) - SIGMA
+         P = GAMMA*GAMMA
+*
+*        Inner loop
+*
+         DO 130 I = M, L - 1
+            BB = E( I )
+            R = P + BB
+            IF( I.NE.M )
+     $         E( I-1 ) = S*R
+            OLDC = C
+            C = P / R
+            S = BB / R
+            OLDGAM = GAMMA
+            ALPHA = D( I+1 )
+            GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+            D( I ) = OLDGAM + ( ALPHA-GAMMA )
+            IF( C.NE.ZERO ) THEN
+               P = ( GAMMA*GAMMA ) / C
+            ELSE
+               P = OLDC*BB
+            END IF
+  130    CONTINUE
+*
+         E( L-1 ) = S*P
+         D( L ) = SIGMA + GAMMA
+         GO TO 100
+*
+*        Eigenvalue found.
+*
+  140    CONTINUE
+         D( L ) = P
+*
+         L = L - 1
+         IF( L.GE.LEND )
+     $      GO TO 100
+         GO TO 150
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+  150 CONTINUE
+      IF( ISCALE.EQ.1 )
+     $   CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+      IF( ISCALE.EQ.2 )
+     $   CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+*
+*     Check for no convergence to an eigenvalue after a total
+*     of N*MAXIT iterations.
+*
+      IF( JTOT.LT.NMAXIT )
+     $   GO TO 10
+      DO 160 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  160 CONTINUE
+      GO TO 180
+*
+*     Sort eigenvalues in increasing order.
+*
+  170 CONTINUE
+      CALL DLASRT( 'I', N, D, INFO )
+*
+  180 CONTINUE
+      RETURN
+*
+*     End of DSTERF
+*
+      END
diff --git a/src/lib/lapack/dsycon.f b/src/lib/lapack/dsycon.f
new file mode 100644
index 00000000..711b48ca
--- /dev/null
+++ b/src/lib/lapack/dsycon.f
@@ -0,0 +1,165 @@
+      SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYCON estimates the reciprocal of the condition number (in the
+*  1-norm) of a real symmetric matrix A using the factorization
+*  A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the details of the factorization are stored
+*          as an upper or lower triangular matrix.
+*          = 'U':  Upper triangular, form is A = U*D*U**T;
+*          = 'L':  Lower triangular, form is A = L*D*L**T.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by DSYTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSYTRF.
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          The 1-norm of the original matrix A.
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*          estimate of the 1-norm of inv(A) computed in this routine.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  IWORK    (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, KASE
+      DOUBLE PRECISION   AINVNM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.LE.ZERO ) THEN
+         RETURN
+      END IF
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         DO 10 I = N, 1, -1
+            IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+     $         RETURN
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         DO 20 I = 1, N
+            IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+     $         RETURN
+   20    CONTINUE
+      END IF
+*
+*     Estimate the 1-norm of the inverse.
+*
+      KASE = 0
+   30 CONTINUE
+      CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+*
+*        Multiply by inv(L*D*L') or inv(U*D*U').
+*
+         CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+         GO TO 30
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+      RETURN
+*
+*     End of DSYCON
+*
+      END
diff --git a/src/lib/lapack/dsyev.f b/src/lib/lapack/dsyev.f
new file mode 100644
index 00000000..d73600a2
--- /dev/null
+++ b/src/lib/lapack/dsyev.f
@@ -0,0 +1,211 @@
+      SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYEV computes all eigenvalues and, optionally, eigenvectors of a
+*  real symmetric matrix A.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+*          orthonormal eigenvectors of the matrix A.
+*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+*          or the upper triangle (if UPLO='U') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,3*N-1).
+*          For optimal efficiency, LWORK >= (NB+2)*N,
+*          where NB is the blocksize for DSYTRD returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the algorithm failed to converge; i
+*                off-diagonal elements of an intermediate tridiagonal
+*                form did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+     $                   LLWORK, LWKOPT, NB
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, DLANSY
+      EXTERNAL           LSAME, ILAENV, DLAMCH, DLANSY
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( 1, ( NB+2 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
+     $      INFO = -8
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         WORK( 1 ) = 2
+         IF( WANTZ )
+     $      A( 1, 1 ) = ONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 )
+     $   CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = INDE + N
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     DORGTR to generate the orthogonal matrix, then call DSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, WORK( INDE ), INFO )
+      ELSE
+         CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+     $                LLWORK, IINFO )
+         CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
+     $                INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     Set WORK(1) to optimal workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DSYEV
+*
+      END
diff --git a/src/lib/lapack/dsysv.f b/src/lib/lapack/dsysv.f
new file mode 100644
index 00000000..add53850
--- /dev/null
+++ b/src/lib/lapack/dsysv.f
@@ -0,0 +1,174 @@
+      SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+     $                  LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYSV computes the solution to a real system of linear equations
+*     A * X = B,
+*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+*  matrices.
+*
+*  The diagonal pivoting method is used to factor A as
+*     A = U * D * U**T,  if UPLO = 'U', or
+*     A = L * D * L**T,  if UPLO = 'L',
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is symmetric and block diagonal with
+*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then
+*  used to solve the system of equations A * X = B.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The number of linear equations, i.e., the order of the
+*          matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the block diagonal matrix D and the
+*          multipliers used to obtain the factor U or L from the
+*          factorization A = U*D*U**T or A = L*D*L**T as computed by
+*          DSYTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D, as
+*          determined by DSYTRF.  If IPIV(k) > 0, then rows and columns
+*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+*          then rows and columns k-1 and -IPIV(k) were interchanged and
+*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
+*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+*          diagonal block.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the N-by-NRHS right hand side matrix B.
+*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >= 1, and for best performance
+*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+*          DSYTRF.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
+*               has been completed, but the block diagonal matrix D is
+*               exactly singular, so the solution could not be computed.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSYTRF, DSYTRS, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+         INFO = -10
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYSV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+      CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+      IF( INFO.EQ.0 ) THEN
+*
+*        Solve the system A*X = B, overwriting B with X.
+*
+         CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DSYSV
+*
+      END
diff --git a/src/lib/lapack/dsytd2.f b/src/lib/lapack/dsytd2.f
new file mode 100644
index 00000000..c696818e
--- /dev/null
+++ b/src/lib/lapack/dsytd2.f
@@ -0,0 +1,248 @@
+      SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
+*  form T by an orthogonal similarity transformation: Q' * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
+*          of A are overwritten by the corresponding elements of the
+*          tridiagonal matrix T, and the elements above the first
+*          superdiagonal, with the array TAU, represent the orthogonal
+*          matrix Q as a product of elementary reflectors; if UPLO
+*          = 'L', the diagonal and first subdiagonal of A are over-
+*          written by the corresponding elements of the tridiagonal
+*          matrix T, and the elements below the first subdiagonal, with
+*          the array TAU, represent the orthogonal matrix Q as a product
+*          of elementary reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n-1) . . . H(2) H(1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+*  A(1:i-1,i+1), and tau in TAU(i).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(n-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+*  and tau in TAU(i).
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  d   e   v2  v3  v4 )              (  d                  )
+*    (      d   e   v3  v4 )              (  e   d              )
+*    (          d   e   v4 )              (  v1  e   d          )
+*    (              d   e  )              (  v1  v2  e   d      )
+*    (                  d  )              (  v1  v2  v3  e   d  )
+*
+*  where d and e denote diagonal and off-diagonal elements of T, and vi
+*  denotes an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO, HALF
+      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0,
+     $                   HALF = 1.0D0 / 2.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      DOUBLE PRECISION   ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTD2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Reduce the upper triangle of A
+*
+         DO 10 I = N - 1, 1, -1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(1:i-1,i+1)
+*
+            CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
+            E( I ) = A( I, I+1 )
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(1:i,1:i)
+*
+               A( I, I+1 ) = ONE
+*
+*              Compute  x := tau * A * v  storing x in TAU(1:i)
+*
+               CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
+     $                     TAU, 1 )
+*
+*              Compute  w := x - 1/2 * tau * (x'*v) * v
+*
+               ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
+               CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
+     $                     LDA )
+*
+               A( I, I+1 ) = E( I )
+            END IF
+            D( I+1 ) = A( I+1, I+1 )
+            TAU( I ) = TAUI
+   10    CONTINUE
+         D( 1 ) = A( 1, 1 )
+      ELSE
+*
+*        Reduce the lower triangle of A
+*
+         DO 20 I = 1, N - 1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(i+2:n,i)
+*
+            CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+     $                   TAUI )
+            E( I ) = A( I+1, I )
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+               A( I+1, I ) = ONE
+*
+*              Compute  x := tau * A * v  storing y in TAU(i:n-1)
+*
+               CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, TAU( I ), 1 )
+*
+*              Compute  w := x - 1/2 * tau * (x'*v) * v
+*
+               ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ),
+     $                 1 )
+               CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
+     $                     A( I+1, I+1 ), LDA )
+*
+               A( I+1, I ) = E( I )
+            END IF
+            D( I ) = A( I, I )
+            TAU( I ) = TAUI
+   20    CONTINUE
+         D( N ) = A( N, N )
+      END IF
+*
+      RETURN
+*
+*     End of DSYTD2
+*
+      END
diff --git a/src/lib/lapack/dsytf2.f b/src/lib/lapack/dsytf2.f
new file mode 100644
index 00000000..d5234625
--- /dev/null
+++ b/src/lib/lapack/dsytf2.f
@@ -0,0 +1,521 @@
+      SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTF2 computes the factorization of a real symmetric matrix A using
+*  the Bunch-Kaufman diagonal pivoting method:
+*
+*     A = U*D*U'  or  A = L*D*L'
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, U' is the transpose of U, and D is symmetric and
+*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          symmetric matrix A is stored:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L (see below for further details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization
+*               has been completed, but the block diagonal matrix D is
+*               exactly singular, and division by zero will occur if it
+*               is used to solve a system of equations.
+*
+*  Further Details
+*  ===============
+*
+*  09-29-06 - patch from
+*    Bobby Cheng, MathWorks
+*
+*    Replace l.204 and l.372
+*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*    by
+*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+*  01-01-96 - Based on modifications by
+*    J. Lewis, Boeing Computer Services Company
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services
+*         Company
+*
+*  If UPLO = 'U', then A = U*D*U', where
+*     U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    v    0   )   k-s
+*     U(k) =  (   0    I    0   )   s
+*             (   0    0    I   )   n-k
+*                k-s   s   n-k
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*  and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+*  If UPLO = 'L', then A = L*D*L', where
+*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    0     0   )  k-1
+*     L(k) =  (   0    I     0   )  s
+*             (   0    v     I   )  n-k-s+1
+*                k-1   s  n-k-s+1
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   EIGHT, SEVTEN
+      PARAMETER          ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I, IMAX, J, JMAX, K, KK, KP, KSTEP
+      DOUBLE PRECISION   ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+     $                   ROWMAX, T, WK, WKM1, WKP1
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME, DISNAN
+      INTEGER            IDAMAX
+      EXTERNAL           LSAME, IDAMAX, DISNAN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSWAP, DSYR, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize ALPHA for use in choosing pivot block size.
+*
+      ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A as U*D*U' using the upper triangle of A
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2
+*
+         K = N
+   10    CONTINUE
+*
+*        If K < 1, exit from loop
+*
+         IF( K.LT.1 )
+     $      GO TO 70
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( A( K, K ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.GT.1 ) THEN
+            IMAX = IDAMAX( K-1, A( 1, K ), 1 )
+            COLMAX = ABS( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or contains a NaN: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+               ROWMAX = ABS( A( IMAX, JMAX ) )
+               IF( IMAX.GT.1 ) THEN
+                  JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+               ELSE
+*
+*                 interchange rows and columns K-1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K - KSTEP + 1
+            IF( KP.NE.KK ) THEN
+*
+*              Interchange rows and columns KK and KP in the leading
+*              submatrix A(1:k,1:k)
+*
+               CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+               CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+     $                     LDA )
+               T = A( KK, KK )
+               A( KK, KK ) = A( KP, KP )
+               A( KP, KP ) = T
+               IF( KSTEP.EQ.2 ) THEN
+                  T = A( K-1, K )
+                  A( K-1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            END IF
+*
+*           Update the leading submatrix
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column k now holds
+*
+*              W(k) = U(k)*D(k)
+*
+*              where U(k) is the k-th column of U
+*
+*              Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+*              A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+               R1 = ONE / A( K, K )
+               CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+*              Store U(k) in column k
+*
+               CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+            ELSE
+*
+*              2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+*              ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+*              where U(k) and U(k-1) are the k-th and (k-1)-th columns
+*              of U
+*
+*              Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+*              A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+*                 = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+               IF( K.GT.2 ) THEN
+*
+                  D12 = A( K-1, K )
+                  D22 = A( K-1, K-1 ) / D12
+                  D11 = A( K, K ) / D12
+                  T = ONE / ( D11*D22-ONE )
+                  D12 = T / D12
+*
+                  DO 30 J = K - 2, 1, -1
+                     WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
+                     WK = D12*( D22*A( J, K )-A( J, K-1 ) )
+                     DO 20 I = J, 1, -1
+                        A( I, J ) = A( I, J ) - A( I, K )*WK -
+     $                              A( I, K-1 )*WKM1
+   20                CONTINUE
+                     A( J, K ) = WK
+                     A( J, K-1 ) = WKM1
+   30             CONTINUE
+*
+               END IF
+*
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K-1 ) = -KP
+         END IF
+*
+*        Decrease K and return to the start of the main loop
+*
+         K = K - KSTEP
+         GO TO 10
+*
+      ELSE
+*
+*        Factorize A as L*D*L' using the lower triangle of A
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2
+*
+         K = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop
+*
+         IF( K.GT.N )
+     $      GO TO 70
+         KSTEP = 1
+*
+*        Determine rows and columns to be interchanged and whether
+*        a 1-by-1 or 2-by-2 pivot block will be used
+*
+         ABSAKK = ABS( A( K, K ) )
+*
+*        IMAX is the row-index of the largest off-diagonal element in
+*        column K, and COLMAX is its absolute value
+*
+         IF( K.LT.N ) THEN
+            IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
+            COLMAX = ABS( A( IMAX, K ) )
+         ELSE
+            COLMAX = ZERO
+         END IF
+*
+         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+*           Column K is zero or contains a NaN: set INFO and continue
+*
+            IF( INFO.EQ.0 )
+     $         INFO = K
+            KP = K
+         ELSE
+            IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+*              no interchange, use 1-by-1 pivot block
+*
+               KP = K
+            ELSE
+*
+*              JMAX is the column-index of the largest off-diagonal
+*              element in row IMAX, and ROWMAX is its absolute value
+*
+               JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
+               ROWMAX = ABS( A( IMAX, JMAX ) )
+               IF( IMAX.LT.N ) THEN
+                  JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+                  ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+               END IF
+*
+               IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+*                 no interchange, use 1-by-1 pivot block
+*
+                  KP = K
+               ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+*                 interchange rows and columns K and IMAX, use 1-by-1
+*                 pivot block
+*
+                  KP = IMAX
+               ELSE
+*
+*                 interchange rows and columns K+1 and IMAX, use 2-by-2
+*                 pivot block
+*
+                  KP = IMAX
+                  KSTEP = 2
+               END IF
+            END IF
+*
+            KK = K + KSTEP - 1
+            IF( KP.NE.KK ) THEN
+*
+*              Interchange rows and columns KK and KP in the trailing
+*              submatrix A(k:n,k:n)
+*
+               IF( KP.LT.N )
+     $            CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+               CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+     $                     LDA )
+               T = A( KK, KK )
+               A( KK, KK ) = A( KP, KP )
+               A( KP, KP ) = T
+               IF( KSTEP.EQ.2 ) THEN
+                  T = A( K+1, K )
+                  A( K+1, K ) = A( KP, K )
+                  A( KP, K ) = T
+               END IF
+            END IF
+*
+*           Update the trailing submatrix
+*
+            IF( KSTEP.EQ.1 ) THEN
+*
+*              1-by-1 pivot block D(k): column k now holds
+*
+*              W(k) = L(k)*D(k)
+*
+*              where L(k) is the k-th column of L
+*
+               IF( K.LT.N ) THEN
+*
+*                 Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+*                 A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+                  D11 = ONE / A( K, K )
+                  CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+     $                       A( K+1, K+1 ), LDA )
+*
+*                 Store L(k) in column K
+*
+                  CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
+               END IF
+            ELSE
+*
+*              2-by-2 pivot block D(k)
+*
+               IF( K.LT.N-1 ) THEN
+*
+*                 Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+*                 A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
+*
+*                 where L(k) and L(k+1) are the k-th and (k+1)-th
+*                 columns of L
+*
+                  D21 = A( K+1, K )
+                  D11 = A( K+1, K+1 ) / D21
+                  D22 = A( K, K ) / D21
+                  T = ONE / ( D11*D22-ONE )
+                  D21 = T / D21
+*
+                  DO 60 J = K + 2, N
+*
+                     WK = D21*( D11*A( J, K )-A( J, K+1 ) )
+                     WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
+*
+                     DO 50 I = J, N
+                        A( I, J ) = A( I, J ) - A( I, K )*WK -
+     $                              A( I, K+1 )*WKP1
+   50                CONTINUE
+*
+                     A( J, K ) = WK
+                     A( J, K+1 ) = WKP1
+*
+   60             CONTINUE
+               END IF
+            END IF
+         END IF
+*
+*        Store details of the interchanges in IPIV
+*
+         IF( KSTEP.EQ.1 ) THEN
+            IPIV( K ) = KP
+         ELSE
+            IPIV( K ) = -KP
+            IPIV( K+1 ) = -KP
+         END IF
+*
+*        Increase K and return to the start of the main loop
+*
+         K = K + KSTEP
+         GO TO 40
+*
+      END IF
+*
+   70 CONTINUE
+*
+      RETURN
+*
+*     End of DSYTF2
+*
+      END
diff --git a/src/lib/lapack/dsytrd.f b/src/lib/lapack/dsytrd.f
new file mode 100644
index 00000000..569ee35b
--- /dev/null
+++ b/src/lib/lapack/dsytrd.f
@@ -0,0 +1,294 @@
+      SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAU( * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTRD reduces a real symmetric matrix A to real symmetric
+*  tridiagonal form T by an orthogonal similarity transformation:
+*  Q**T * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
+*          of A are overwritten by the corresponding elements of the
+*          tridiagonal matrix T, and the elements above the first
+*          superdiagonal, with the array TAU, represent the orthogonal
+*          matrix Q as a product of elementary reflectors; if UPLO
+*          = 'L', the diagonal and first subdiagonal of A are over-
+*          written by the corresponding elements of the tridiagonal
+*          matrix T, and the elements below the first subdiagonal, with
+*          the array TAU, represent the orthogonal matrix Q as a product
+*          of elementary reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= 1.
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n-1) . . . H(2) H(1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+*  A(1:i-1,i+1), and tau in TAU(i).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(n-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real scalar, and v is a real vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+*  and tau in TAU(i).
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  d   e   v2  v3  v4 )              (  d                  )
+*    (      d   e   v3  v4 )              (  e   d              )
+*    (          d   e   v4 )              (  v1  e   d          )
+*    (              d   e  )              (  v1  v2  e   d      )
+*    (                  d  )              (  v1  v2  v3  e   d  )
+*
+*  where d and e denote diagonal and off-diagonal elements of T, and vi
+*  denotes an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLATRD, DSYR2K, DSYTD2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.
+*
+         NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NX = N
+      IWS = 1
+      IF( NB.GT.1 .AND. NB.LT.N ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code
+*        (last block is always handled by unblocked code).
+*
+         NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
+         IF( NX.LT.N ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  determine the
+*              minimum value of NB, and reduce NB or force use of
+*              unblocked code by setting NX = N.
+*
+               NB = MAX( LWORK / LDWORK, 1 )
+               NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
+               IF( NB.LT.NBMIN )
+     $            NX = N
+            END IF
+         ELSE
+            NX = N
+         END IF
+      ELSE
+         NB = 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Reduce the upper triangle of A.
+*        Columns 1:kk are handled by the unblocked method.
+*
+         KK = N - ( ( N-NX+NB-1 ) / NB )*NB
+         DO 20 I = N - NB + 1, KK + 1, -NB
+*
+*           Reduce columns i:i+nb-1 to tridiagonal form and form the
+*           matrix W which is needed to update the unreduced part of
+*           the matrix
+*
+            CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
+     $                   LDWORK )
+*
+*           Update the unreduced submatrix A(1:i-1,1:i-1), using an
+*           update of the form:  A := A - V*W' - W*V'
+*
+            CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
+     $                   LDA, WORK, LDWORK, ONE, A, LDA )
+*
+*           Copy superdiagonal elements back into A, and diagonal
+*           elements into D
+*
+            DO 10 J = I, I + NB - 1
+               A( J-1, J ) = E( J-1 )
+               D( J ) = A( J, J )
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Use unblocked code to reduce the last or only block
+*
+         CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
+      ELSE
+*
+*        Reduce the lower triangle of A
+*
+         DO 40 I = 1, N - NX, NB
+*
+*           Reduce columns i:i+nb-1 to tridiagonal form and form the
+*           matrix W which is needed to update the unreduced part of
+*           the matrix
+*
+            CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
+     $                   TAU( I ), WORK, LDWORK )
+*
+*           Update the unreduced submatrix A(i+ib:n,i+ib:n), using
+*           an update of the form:  A := A - V*W' - W*V'
+*
+            CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
+     $                   A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
+     $                   A( I+NB, I+NB ), LDA )
+*
+*           Copy subdiagonal elements back into A, and diagonal
+*           elements into D
+*
+            DO 30 J = I, I + NB - 1
+               A( J+1, J ) = E( J )
+               D( J ) = A( J, J )
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Use unblocked code to reduce the last or only block
+*
+         CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $                TAU( I ), IINFO )
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DSYTRD
+*
+      END
diff --git a/src/lib/lapack/dsytrf.f b/src/lib/lapack/dsytrf.f
new file mode 100644
index 00000000..43a31248
--- /dev/null
+++ b/src/lib/lapack/dsytrf.f
@@ -0,0 +1,287 @@
+      SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTRF computes the factorization of a real symmetric matrix A using
+*  the Bunch-Kaufman diagonal pivoting method.  The form of the
+*  factorization is
+*
+*     A = U*D*U**T  or  A = L*D*L**T
+*
+*  where U (or L) is a product of permutation and unit upper (lower)
+*  triangular matrices, and D is symmetric and block diagonal with
+*  1-by-1 and 2-by-2 diagonal blocks.
+*
+*  This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, the block diagonal matrix D and the multipliers used
+*          to obtain the factor U or L (see below for further details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (output) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D.
+*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+*          interchanged and D(k,k) is a 1-by-1 diagonal block.
+*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =
+*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of WORK.  LWORK >=1.  For best performance
+*          LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization
+*                has been completed, but the block diagonal matrix D is
+*                exactly singular, and division by zero will occur if it
+*                is used to solve a system of equations.
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', then A = U*D*U', where
+*     U = P(n)*U(n)* ... *P(k)U(k)* ...,
+*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    v    0   )   k-s
+*     U(k) =  (   0    I    0   )   s
+*             (   0    0    I   )   n-k
+*                k-s   s   n-k
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+*  and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+*  If UPLO = 'L', then A = L*D*L', where
+*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as
+*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+*  that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+*             (   I    0     0   )  k-1
+*     L(k) =  (   0    I     0   )  s
+*             (   0    v     I   )  n-k-s+1
+*                k-1   s  n-k-s+1
+*
+*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASYF, DSYTF2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size
+*
+         NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = N
+      IF( NB.GT.1 .AND. NB.LT.N ) THEN
+         IWS = LDWORK*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = MAX( LWORK / LDWORK, 1 )
+            NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )
+         END IF
+      ELSE
+         IWS = 1
+      END IF
+      IF( NB.LT.NBMIN )
+     $   NB = N
+*
+      IF( UPPER ) THEN
+*
+*        Factorize A as U*D*U' using the upper triangle of A
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        KB, where KB is the number of columns factorized by DLASYF;
+*        KB is either NB or NB-1, or K for the last block
+*
+         K = N
+   10    CONTINUE
+*
+*        If K < 1, exit from loop
+*
+         IF( K.LT.1 )
+     $      GO TO 40
+*
+         IF( K.GT.NB ) THEN
+*
+*           Factorize columns k-kb+1:k of A and use blocked code to
+*           update columns 1:k-kb
+*
+            CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
+     $                   IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns 1:k of A
+*
+            CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
+            KB = K
+         END IF
+*
+*        Set INFO on the first occurrence of a zero pivot
+*
+         IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+     $      INFO = IINFO
+*
+*        Decrease K and return to the start of the main loop
+*
+         K = K - KB
+         GO TO 10
+*
+      ELSE
+*
+*        Factorize A as L*D*L' using the lower triangle of A
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        KB, where KB is the number of columns factorized by DLASYF;
+*        KB is either NB or NB-1, or N-K+1 for the last block
+*
+         K = 1
+   20    CONTINUE
+*
+*        If K > N, exit from loop
+*
+         IF( K.GT.N )
+     $      GO TO 40
+*
+         IF( K.LE.N-NB ) THEN
+*
+*           Factorize columns k:k+kb-1 of A and use blocked code to
+*           update columns k+kb:n
+*
+            CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+     $                   WORK, LDWORK, IINFO )
+         ELSE
+*
+*           Use unblocked code to factorize columns k:n of A
+*
+            CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
+            KB = N - K + 1
+         END IF
+*
+*        Set INFO on the first occurrence of a zero pivot
+*
+         IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+     $      INFO = IINFO + K - 1
+*
+*        Adjust IPIV
+*
+         DO 30 J = K, K + KB - 1
+            IF( IPIV( J ).GT.0 ) THEN
+               IPIV( J ) = IPIV( J ) + K - 1
+            ELSE
+               IPIV( J ) = IPIV( J ) - K + 1
+            END IF
+   30    CONTINUE
+*
+*        Increase K and return to the start of the main loop
+*
+         K = K + KB
+         GO TO 20
+*
+      END IF
+*
+   40 CONTINUE
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of DSYTRF
+*
+      END
diff --git a/src/lib/lapack/dsytri.f b/src/lib/lapack/dsytri.f
new file mode 100644
index 00000000..361de9a3
--- /dev/null
+++ b/src/lib/lapack/dsytri.f
@@ -0,0 +1,312 @@
+      SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTRI computes the inverse of a real symmetric indefinite matrix
+*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by
+*  DSYTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the details of the factorization are stored
+*          as an upper or lower triangular matrix.
+*          = 'U':  Upper triangular, form is A = U*D*U**T;
+*          = 'L':  Lower triangular, form is A = L*D*L**T.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the block diagonal matrix D and the multipliers
+*          used to obtain the factor U or L as computed by DSYTRF.
+*
+*          On exit, if INFO = 0, the (symmetric) inverse of the original
+*          matrix.  If UPLO = 'U', the upper triangular part of the
+*          inverse is formed and the part of A below the diagonal is not
+*          referenced; if UPLO = 'L' the lower triangular part of the
+*          inverse is formed and the part of A above the diagonal is
+*          not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSYTRF.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*               inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            K, KP, KSTEP
+      DOUBLE PRECISION   AK, AKKP1, AKP1, D, T, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT
+      EXTERNAL           LSAME, DDOT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DCOPY, DSWAP, DSYMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check that the diagonal matrix D is nonsingular.
+*
+      IF( UPPER ) THEN
+*
+*        Upper triangular storage: examine D from bottom to top
+*
+         DO 10 INFO = N, 1, -1
+            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+     $         RETURN
+   10    CONTINUE
+      ELSE
+*
+*        Lower triangular storage: examine D from top to bottom.
+*
+         DO 20 INFO = 1, N
+            IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+     $         RETURN
+   20    CONTINUE
+      END IF
+      INFO = 0
+*
+      IF( UPPER ) THEN
+*
+*        Compute inv(A) from the factorization A = U*D*U'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+   30    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 40
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / A( K, K )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( A( K, K+1 ) )
+            AK = A( K, K ) / T
+            AKP1 = A( K+1, K+1 ) / T
+            AKKP1 = A( K, K+1 ) / T
+            D = T*( AK*AKP1-ONE )
+            A( K, K ) = AKP1 / D
+            A( K+1, K+1 ) = AK / D
+            A( K, K+1 ) = -AKKP1 / D
+*
+*           Compute columns K and K+1 of the inverse.
+*
+            IF( K.GT.1 ) THEN
+               CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K ), 1 )
+               A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+     $                     1 )
+               A( K, K+1 ) = A( K, K+1 ) -
+     $                       DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+               CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+     $                     A( 1, K+1 ), 1 )
+               A( K+1, K+1 ) = A( K+1, K+1 ) -
+     $                         DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
+            END IF
+            KSTEP = 2
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the leading
+*           submatrix A(1:k+1,1:k+1)
+*
+            CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+            CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+            TEMP = A( K, K )
+            A( K, K ) = A( KP, KP )
+            A( KP, KP ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = A( K, K+1 )
+               A( K, K+1 ) = A( KP, K+1 )
+               A( KP, K+1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K + KSTEP
+         GO TO 30
+   40    CONTINUE
+*
+      ELSE
+*
+*        Compute inv(A) from the factorization A = L*D*L'.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+   50    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 60
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Invert the diagonal block.
+*
+            A( K, K ) = ONE / A( K, K )
+*
+*           Compute column K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+            END IF
+            KSTEP = 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Invert the diagonal block.
+*
+            T = ABS( A( K, K-1 ) )
+            AK = A( K-1, K-1 ) / T
+            AKP1 = A( K, K ) / T
+            AKKP1 = A( K, K-1 ) / T
+            D = T*( AK*AKP1-ONE )
+            A( K-1, K-1 ) = AKP1 / D
+            A( K, K ) = AK / D
+            A( K, K-1 ) = -AKKP1 / D
+*
+*           Compute columns K-1 and K of the inverse.
+*
+            IF( K.LT.N ) THEN
+               CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K ), 1 )
+               A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+     $                     1 )
+               A( K, K-1 ) = A( K, K-1 ) -
+     $                       DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+     $                       1 )
+               CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+               CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+     $                     ZERO, A( K+1, K-1 ), 1 )
+               A( K-1, K-1 ) = A( K-1, K-1 ) -
+     $                         DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+            END IF
+            KSTEP = 2
+         END IF
+*
+         KP = ABS( IPIV( K ) )
+         IF( KP.NE.K ) THEN
+*
+*           Interchange rows and columns K and KP in the trailing
+*           submatrix A(k-1:n,k-1:n)
+*
+            IF( KP.LT.N )
+     $         CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+            CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+            TEMP = A( K, K )
+            A( K, K ) = A( KP, KP )
+            A( KP, KP ) = TEMP
+            IF( KSTEP.EQ.2 ) THEN
+               TEMP = A( K, K-1 )
+               A( K, K-1 ) = A( KP, K-1 )
+               A( KP, K-1 ) = TEMP
+            END IF
+         END IF
+*
+         K = K - KSTEP
+         GO TO 50
+   60    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSYTRI
+*
+      END
diff --git a/src/lib/lapack/dsytrs.f b/src/lib/lapack/dsytrs.f
new file mode 100644
index 00000000..163ed5b9
--- /dev/null
+++ b/src/lib/lapack/dsytrs.f
@@ -0,0 +1,369 @@
+      SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYTRS solves a system of linear equations A*X = B with a real
+*  symmetric matrix A using the factorization A = U*D*U**T or
+*  A = L*D*L**T computed by DSYTRF.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the details of the factorization are stored
+*          as an upper or lower triangular matrix.
+*          = 'U':  Upper triangular, form is A = U*D*U**T;
+*          = 'L':  Lower triangular, form is A = L*D*L**T.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The block diagonal matrix D and the multipliers used to
+*          obtain the factor U or L as computed by DSYTRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          Details of the interchanges and the block structure of D
+*          as determined by DSYTRF.
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit, the solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, K, KP
+      DOUBLE PRECISION   AK, AKM1, AKM1K, BK, BKM1, DENOM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DGER, DSCAL, DSWAP, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DSYTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Solve A*X = B, where A = U*D*U'.
+*
+*        First solve U*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+   10    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 30
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(U(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K-1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K-1 )
+     $         CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(U(K)), where U(K) is the transformation
+*           stored in columns K-1 and K of A.
+*
+            CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+     $                 B( 1, 1 ), LDB )
+            CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+     $                 LDB, B( 1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = A( K-1, K )
+            AKM1 = A( K-1, K-1 ) / AKM1K
+            AK = A( K, K ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 20 J = 1, NRHS
+               BKM1 = B( K-1, J ) / AKM1K
+               BK = B( K, J ) / AKM1K
+               B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   20       CONTINUE
+            K = K - 2
+         END IF
+*
+         GO TO 10
+   30    CONTINUE
+*
+*        Next solve U'*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+   40    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 50
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(U'(K)), where U(K) is the transformation
+*           stored in column K of A.
+*
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+     $                  1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+     $                  1, ONE, B( K, 1 ), LDB )
+            CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+     $                  A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K + 2
+         END IF
+*
+         GO TO 40
+   50    CONTINUE
+*
+      ELSE
+*
+*        Solve A*X = B, where A = L*D*L'.
+*
+*        First solve L*D*X = B, overwriting B with X.
+*
+*        K is the main loop index, increasing from 1 to N in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = 1
+   60    CONTINUE
+*
+*        If K > N, exit from loop.
+*
+         IF( K.GT.N )
+     $      GO TO 80
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(L(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+     $                    LDB, B( K+1, 1 ), LDB )
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+            K = K + 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Interchange rows K+1 and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K+1 )
+     $         CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+*           Multiply by inv(L(K)), where L(K) is the transformation
+*           stored in columns K and K+1 of A.
+*
+            IF( K.LT.N-1 ) THEN
+               CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+     $                    LDB, B( K+2, 1 ), LDB )
+               CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+     $                    B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+            END IF
+*
+*           Multiply by the inverse of the diagonal block.
+*
+            AKM1K = A( K+1, K )
+            AKM1 = A( K, K ) / AKM1K
+            AK = A( K+1, K+1 ) / AKM1K
+            DENOM = AKM1*AK - ONE
+            DO 70 J = 1, NRHS
+               BKM1 = B( K, J ) / AKM1K
+               BK = B( K+1, J ) / AKM1K
+               B( K, J ) = ( AK*BKM1-BK ) / DENOM
+               B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+   70       CONTINUE
+            K = K + 2
+         END IF
+*
+         GO TO 60
+   80    CONTINUE
+*
+*        Next solve L'*X = B, overwriting B with X.
+*
+*        K is the main loop index, decreasing from N to 1 in steps of
+*        1 or 2, depending on the size of the diagonal blocks.
+*
+         K = N
+   90    CONTINUE
+*
+*        If K < 1, exit from loop.
+*
+         IF( K.LT.1 )
+     $      GO TO 100
+*
+         IF( IPIV( K ).GT.0 ) THEN
+*
+*           1 x 1 diagonal block
+*
+*           Multiply by inv(L'(K)), where L(K) is the transformation
+*           stored in column K of A.
+*
+            IF( K.LT.N )
+     $         CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+*           Interchange rows K and IPIV(K).
+*
+            KP = IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 1
+         ELSE
+*
+*           2 x 2 diagonal block
+*
+*           Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+*           stored in columns K-1 and K of A.
+*
+            IF( K.LT.N ) THEN
+               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+               CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+     $                     LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
+     $                     LDB )
+            END IF
+*
+*           Interchange rows K and -IPIV(K).
+*
+            KP = -IPIV( K )
+            IF( KP.NE.K )
+     $         CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+            K = K - 2
+         END IF
+*
+         GO TO 90
+  100    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DSYTRS
+*
+      END
diff --git a/src/lib/lapack/dtgevc.f b/src/lib/lapack/dtgevc.f
new file mode 100644
index 00000000..091c3f65
--- /dev/null
+++ b/src/lib/lapack/dtgevc.f
@@ -0,0 +1,1147 @@
+      SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
+     $                   LDVL, VR, LDVR, MM, M, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, SIDE
+      INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      DOUBLE PRECISION   P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  DTGEVC computes some or all of the right and/or left eigenvectors of
+*  a pair of real matrices (S,P), where S is a quasi-triangular matrix
+*  and P is upper triangular.  Matrix pairs of this type are produced by
+*  the generalized Schur factorization of a matrix pair (A,B):
+*
+*     A = Q*S*Z**T,  B = Q*P*Z**T
+*
+*  as computed by DGGHRD + DHGEQZ.
+*
+*  The right eigenvector x and the left eigenvector y of (S,P)
+*  corresponding to an eigenvalue w are defined by:
+*  
+*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
+*  
+*  where y**H denotes the conjugate tranpose of y.
+*  The eigenvalues are not input to this routine, but are computed
+*  directly from the diagonal blocks of S and P.
+*  
+*  This routine returns the matrices X and/or Y of right and left
+*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,
+*  where Z and Q are input matrices.
+*  If Q and Z are the orthogonal factors from the generalized Schur
+*  factorization of a matrix pair (A,B), then Z*X and Q*Y
+*  are the matrices of right and left eigenvectors of (A,B).
+* 
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute all right and/or left eigenvectors;
+*          = 'B': compute all right and/or left eigenvectors,
+*                 backtransformed by the matrices in VR and/or VL;
+*          = 'S': compute selected right and/or left eigenvectors,
+*                 specified by the logical array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY='S', SELECT specifies the eigenvectors to be
+*          computed.  If w(j) is a real eigenvalue, the corresponding
+*          real eigenvector is computed if SELECT(j) is .TRUE..
+*          If w(j) and w(j+1) are the real and imaginary parts of a
+*          complex eigenvalue, the corresponding complex eigenvector
+*          is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
+*          and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
+*          set to .FALSE..
+*          Not referenced if HOWMNY = 'A' or 'B'.
+*
+*  N       (input) INTEGER
+*          The order of the matrices S and P.  N >= 0.
+*
+*  S       (input) DOUBLE PRECISION array, dimension (LDS,N)
+*          The upper quasi-triangular matrix S from a generalized Schur
+*          factorization, as computed by DHGEQZ.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of array S.  LDS >= max(1,N).
+*
+*  P       (input) DOUBLE PRECISION array, dimension (LDP,N)
+*          The upper triangular matrix P from a generalized Schur
+*          factorization, as computed by DHGEQZ.
+*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
+*          of S must be in positive diagonal form.
+*
+*  LDP     (input) INTEGER
+*          The leading dimension of array P.  LDP >= max(1,N).
+*
+*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*          contain an N-by-N matrix Q (usually the orthogonal matrix Q
+*          of left Schur vectors returned by DHGEQZ).
+*          On exit, if SIDE = 'L' or 'B', VL contains:
+*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
+*          if HOWMNY = 'B', the matrix Q*Y;
+*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
+*                      SELECT, stored consecutively in the columns of
+*                      VL, in the same order as their eigenvalues.
+*
+*          A complex eigenvector corresponding to a complex eigenvalue
+*          is stored in two consecutive columns, the first holding the
+*          real part, and the second the imaginary part.
+*
+*          Not referenced if SIDE = 'R'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of array VL.  LDVL >= 1, and if
+*          SIDE = 'L' or 'B', LDVL >= N.
+*
+*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*          contain an N-by-N matrix Z (usually the orthogonal matrix Z
+*          of right Schur vectors returned by DHGEQZ).
+*
+*          On exit, if SIDE = 'R' or 'B', VR contains:
+*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
+*          if HOWMNY = 'B' or 'b', the matrix Z*X;
+*          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
+*                      specified by SELECT, stored consecutively in the
+*                      columns of VR, in the same order as their
+*                      eigenvalues.
+*
+*          A complex eigenvector corresponding to a complex eigenvalue
+*          is stored in two consecutive columns, the first holding the
+*          real part and the second the imaginary part.
+*          
+*          Not referenced if SIDE = 'L'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1, and if
+*          SIDE = 'R' or 'B', LDVR >= N.
+*
+*  MM      (input) INTEGER
+*          The number of columns in the arrays VL and/or VR. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of columns in the arrays VL and/or VR actually
+*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
+*          is set to N.  Each selected real eigenvector occupies one
+*          column and each selected complex eigenvector occupies two
+*          columns.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex
+*                eigenvalue.
+*
+*  Further Details
+*  ===============
+*
+*  Allocation of workspace:
+*  ---------- -- ---------
+*
+*     WORK( j ) = 1-norm of j-th column of A, above the diagonal
+*     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
+*     WORK( 2*N+1:3*N ) = real part of eigenvector
+*     WORK( 3*N+1:4*N ) = imaginary part of eigenvector
+*     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
+*     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
+*
+*  Rowwise vs. columnwise solution methods:
+*  ------- --  ---------- -------- -------
+*
+*  Finding a generalized eigenvector consists basically of solving the
+*  singular triangular system
+*
+*   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)
+*
+*  Consider finding the i-th right eigenvector (assume all eigenvalues
+*  are real). The equation to be solved is:
+*       n                   i
+*  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1
+*      k=j                 k=j
+*
+*  where  C = (A - w B)  (The components v(i+1:n) are 0.)
+*
+*  The "rowwise" method is:
+*
+*  (1)  v(i) := 1
+*  for j = i-1,. . .,1:
+*                          i
+*      (2) compute  s = - sum C(j,k) v(k)   and
+*                        k=j+1
+*
+*      (3) v(j) := s / C(j,j)
+*
+*  Step 2 is sometimes called the "dot product" step, since it is an
+*  inner product between the j-th row and the portion of the eigenvector
+*  that has been computed so far.
+*
+*  The "columnwise" method consists basically in doing the sums
+*  for all the rows in parallel.  As each v(j) is computed, the
+*  contribution of v(j) times the j-th column of C is added to the
+*  partial sums.  Since FORTRAN arrays are stored columnwise, this has
+*  the advantage that at each step, the elements of C that are accessed
+*  are adjacent to one another, whereas with the rowwise method, the
+*  elements accessed at a step are spaced LDS (and LDP) words apart.
+*
+*  When finding left eigenvectors, the matrix in question is the
+*  transpose of the one in storage, so the rowwise method then
+*  actually accesses columns of A and B at each step, and so is the
+*  preferred method.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, SAFETY
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
+     $                   SAFETY = 1.0D+2 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
+     $                   ILBBAD, ILCOMP, ILCPLX, LSA, LSB
+      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
+     $                   J, JA, JC, JE, JR, JW, NA, NW
+      DOUBLE PRECISION   ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
+     $                   BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
+     $                   CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
+     $                   CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
+     $                   SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
+     $                   XSCALE
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
+     $                   SUMP( 2, 2 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test the input parameters
+*
+      IF( LSAME( HOWMNY, 'A' ) ) THEN
+         IHWMNY = 1
+         ILALL = .TRUE.
+         ILBACK = .FALSE.
+      ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
+         IHWMNY = 2
+         ILALL = .FALSE.
+         ILBACK = .FALSE.
+      ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
+         IHWMNY = 3
+         ILALL = .TRUE.
+         ILBACK = .TRUE.
+      ELSE
+         IHWMNY = -1
+         ILALL = .TRUE.
+      END IF
+*
+      IF( LSAME( SIDE, 'R' ) ) THEN
+         ISIDE = 1
+         COMPL = .FALSE.
+         COMPR = .TRUE.
+      ELSE IF( LSAME( SIDE, 'L' ) ) THEN
+         ISIDE = 2
+         COMPL = .TRUE.
+         COMPR = .FALSE.
+      ELSE IF( LSAME( SIDE, 'B' ) ) THEN
+         ISIDE = 3
+         COMPL = .TRUE.
+         COMPR = .TRUE.
+      ELSE
+         ISIDE = -1
+      END IF
+*
+      INFO = 0
+      IF( ISIDE.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( IHWMNY.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Count the number of eigenvectors to be computed
+*
+      IF( .NOT.ILALL ) THEN
+         IM = 0
+         ILCPLX = .FALSE.
+         DO 10 J = 1, N
+            IF( ILCPLX ) THEN
+               ILCPLX = .FALSE.
+               GO TO 10
+            END IF
+            IF( J.LT.N ) THEN
+               IF( S( J+1, J ).NE.ZERO )
+     $            ILCPLX = .TRUE.
+            END IF
+            IF( ILCPLX ) THEN
+               IF( SELECT( J ) .OR. SELECT( J+1 ) )
+     $            IM = IM + 2
+            ELSE
+               IF( SELECT( J ) )
+     $            IM = IM + 1
+            END IF
+   10    CONTINUE
+      ELSE
+         IM = N
+      END IF
+*
+*     Check 2-by-2 diagonal blocks of A, B
+*
+      ILABAD = .FALSE.
+      ILBBAD = .FALSE.
+      DO 20 J = 1, N - 1
+         IF( S( J+1, J ).NE.ZERO ) THEN
+            IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
+     $          P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
+            IF( J.LT.N-1 ) THEN
+               IF( S( J+2, J+1 ).NE.ZERO )
+     $            ILABAD = .TRUE.
+            END IF
+         END IF
+   20 CONTINUE
+*
+      IF( ILABAD ) THEN
+         INFO = -5
+      ELSE IF( ILBBAD ) THEN
+         INFO = -7
+      ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
+         INFO = -10
+      ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
+         INFO = -12
+      ELSE IF( MM.LT.IM ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = IM
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Machine Constants
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      BIG = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, BIG )
+      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+      SMALL = SAFMIN*N / ULP
+      BIG = ONE / SMALL
+      BIGNUM = ONE / ( SAFMIN*N )
+*
+*     Compute the 1-norm of each column of the strictly upper triangular
+*     part (i.e., excluding all elements belonging to the diagonal
+*     blocks) of A and B to check for possible overflow in the
+*     triangular solver.
+*
+      ANORM = ABS( S( 1, 1 ) )
+      IF( N.GT.1 )
+     $   ANORM = ANORM + ABS( S( 2, 1 ) )
+      BNORM = ABS( P( 1, 1 ) )
+      WORK( 1 ) = ZERO
+      WORK( N+1 ) = ZERO
+*
+      DO 50 J = 2, N
+         TEMP = ZERO
+         TEMP2 = ZERO
+         IF( S( J, J-1 ).EQ.ZERO ) THEN
+            IEND = J - 1
+         ELSE
+            IEND = J - 2
+         END IF
+         DO 30 I = 1, IEND
+            TEMP = TEMP + ABS( S( I, J ) )
+            TEMP2 = TEMP2 + ABS( P( I, J ) )
+   30    CONTINUE
+         WORK( J ) = TEMP
+         WORK( N+J ) = TEMP2
+         DO 40 I = IEND + 1, MIN( J+1, N )
+            TEMP = TEMP + ABS( S( I, J ) )
+            TEMP2 = TEMP2 + ABS( P( I, J ) )
+   40    CONTINUE
+         ANORM = MAX( ANORM, TEMP )
+         BNORM = MAX( BNORM, TEMP2 )
+   50 CONTINUE
+*
+      ASCALE = ONE / MAX( ANORM, SAFMIN )
+      BSCALE = ONE / MAX( BNORM, SAFMIN )
+*
+*     Left eigenvectors
+*
+      IF( COMPL ) THEN
+         IEIG = 0
+*
+*        Main loop over eigenvalues
+*
+         ILCPLX = .FALSE.
+         DO 220 JE = 1, N
+*
+*           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+*           (b) this would be the second of a complex pair.
+*           Check for complex eigenvalue, so as to be sure of which
+*           entry(-ies) of SELECT to look at.
+*
+            IF( ILCPLX ) THEN
+               ILCPLX = .FALSE.
+               GO TO 220
+            END IF
+            NW = 1
+            IF( JE.LT.N ) THEN
+               IF( S( JE+1, JE ).NE.ZERO ) THEN
+                  ILCPLX = .TRUE.
+                  NW = 2
+               END IF
+            END IF
+            IF( ILALL ) THEN
+               ILCOMP = .TRUE.
+            ELSE IF( ILCPLX ) THEN
+               ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
+            ELSE
+               ILCOMP = SELECT( JE )
+            END IF
+            IF( .NOT.ILCOMP )
+     $         GO TO 220
+*
+*           Decide if (a) singular pencil, (b) real eigenvalue, or
+*           (c) complex eigenvalue.
+*
+            IF( .NOT.ILCPLX ) THEN
+               IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+     $             ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+*                 Singular matrix pencil -- return unit eigenvector
+*
+                  IEIG = IEIG + 1
+                  DO 60 JR = 1, N
+                     VL( JR, IEIG ) = ZERO
+   60             CONTINUE
+                  VL( IEIG, IEIG ) = ONE
+                  GO TO 220
+               END IF
+            END IF
+*
+*           Clear vector
+*
+            DO 70 JR = 1, NW*N
+               WORK( 2*N+JR ) = ZERO
+   70       CONTINUE
+*                                                 T
+*           Compute coefficients in  ( a A - b B )  y = 0
+*              a  is  ACOEF
+*              b  is  BCOEFR + i*BCOEFI
+*
+            IF( .NOT.ILCPLX ) THEN
+*
+*              Real eigenvalue
+*
+               TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+     $                ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+               SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+               ACOEF = SBETA*ASCALE
+               BCOEFR = SALFAR*BSCALE
+               BCOEFI = ZERO
+*
+*              Scale to avoid underflow
+*
+               SCALE = ONE
+               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+               LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+     $               SMALL
+               IF( LSA )
+     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+               IF( LSB )
+     $            SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+     $                    MIN( BNORM, BIG ) )
+               IF( LSA .OR. LSB ) THEN
+                  SCALE = MIN( SCALE, ONE /
+     $                    ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+     $                    ABS( BCOEFR ) ) ) )
+                  IF( LSA ) THEN
+                     ACOEF = ASCALE*( SCALE*SBETA )
+                  ELSE
+                     ACOEF = SCALE*ACOEF
+                  END IF
+                  IF( LSB ) THEN
+                     BCOEFR = BSCALE*( SCALE*SALFAR )
+                  ELSE
+                     BCOEFR = SCALE*BCOEFR
+                  END IF
+               END IF
+               ACOEFA = ABS( ACOEF )
+               BCOEFA = ABS( BCOEFR )
+*
+*              First component is 1
+*
+               WORK( 2*N+JE ) = ONE
+               XMAX = ONE
+            ELSE
+*
+*              Complex eigenvalue
+*
+               CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
+     $                     SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+     $                     BCOEFI )
+               BCOEFI = -BCOEFI
+               IF( BCOEFI.EQ.ZERO ) THEN
+                  INFO = JE
+                  RETURN
+               END IF
+*
+*              Scale to avoid over/underflow
+*
+               ACOEFA = ABS( ACOEF )
+               BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+               SCALE = ONE
+               IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+     $            SCALE = ( SAFMIN / ULP ) / ACOEFA
+               IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+     $            SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+               IF( SAFMIN*ACOEFA.GT.ASCALE )
+     $            SCALE = ASCALE / ( SAFMIN*ACOEFA )
+               IF( SAFMIN*BCOEFA.GT.BSCALE )
+     $            SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+               IF( SCALE.NE.ONE ) THEN
+                  ACOEF = SCALE*ACOEF
+                  ACOEFA = ABS( ACOEF )
+                  BCOEFR = SCALE*BCOEFR
+                  BCOEFI = SCALE*BCOEFI
+                  BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+               END IF
+*
+*              Compute first two components of eigenvector
+*
+               TEMP = ACOEF*S( JE+1, JE )
+               TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+               TEMP2I = -BCOEFI*P( JE, JE )
+               IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+                  WORK( 2*N+JE ) = ONE
+                  WORK( 3*N+JE ) = ZERO
+                  WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
+                  WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
+               ELSE
+                  WORK( 2*N+JE+1 ) = ONE
+                  WORK( 3*N+JE+1 ) = ZERO
+                  TEMP = ACOEF*S( JE, JE+1 )
+                  WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
+     $                             S( JE+1, JE+1 ) ) / TEMP
+                  WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
+               END IF
+               XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+     $                ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
+            END IF
+*
+            DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+*                                           T
+*           Triangular solve of  (a A - b B)  y = 0
+*
+*                                   T
+*           (rowwise in  (a A - b B) , or columnwise in (a A - b B) )
+*
+            IL2BY2 = .FALSE.
+*
+            DO 160 J = JE + NW, N
+               IF( IL2BY2 ) THEN
+                  IL2BY2 = .FALSE.
+                  GO TO 160
+               END IF
+*
+               NA = 1
+               BDIAG( 1 ) = P( J, J )
+               IF( J.LT.N ) THEN
+                  IF( S( J+1, J ).NE.ZERO ) THEN
+                     IL2BY2 = .TRUE.
+                     BDIAG( 2 ) = P( J+1, J+1 )
+                     NA = 2
+                  END IF
+               END IF
+*
+*              Check whether scaling is necessary for dot products
+*
+               XSCALE = ONE / MAX( ONE, XMAX )
+               TEMP = MAX( WORK( J ), WORK( N+J ),
+     $                ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
+               IF( IL2BY2 )
+     $            TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
+     $                   ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
+               IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+                  DO 90 JW = 0, NW - 1
+                     DO 80 JR = JE, J - 1
+                        WORK( ( JW+2 )*N+JR ) = XSCALE*
+     $                     WORK( ( JW+2 )*N+JR )
+   80                CONTINUE
+   90             CONTINUE
+                  XMAX = XMAX*XSCALE
+               END IF
+*
+*              Compute dot products
+*
+*                    j-1
+*              SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k)
+*                    k=je
+*
+*              To reduce the op count, this is done as
+*
+*              _        j-1                  _        j-1
+*              a*conjg( sum  S(k,j)*x(k) ) - b*conjg( sum  P(k,j)*x(k) )
+*                       k=je                          k=je
+*
+*              which may cause underflow problems if A or B are close
+*              to underflow.  (E.g., less than SMALL.)
+*
+*
+*              A series of compiler directives to defeat vectorization
+*              for the next loop
+*
+*$PL$ CMCHAR=' '
+CDIR$          NEXTSCALAR
+C$DIR          SCALAR
+CDIR$          NEXT SCALAR
+CVD$L          NOVECTOR
+CDEC$          NOVECTOR
+CVD$           NOVECTOR
+*VDIR          NOVECTOR
+*VOCL          LOOP,SCALAR
+CIBM           PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+               DO 120 JW = 1, NW
+*
+*$PL$ CMCHAR=' '
+CDIR$             NEXTSCALAR
+C$DIR             SCALAR
+CDIR$             NEXT SCALAR
+CVD$L             NOVECTOR
+CDEC$             NOVECTOR
+CVD$              NOVECTOR
+*VDIR             NOVECTOR
+*VOCL             LOOP,SCALAR
+CIBM              PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+                  DO 110 JA = 1, NA
+                     SUMS( JA, JW ) = ZERO
+                     SUMP( JA, JW ) = ZERO
+*
+                     DO 100 JR = JE, J - 1
+                        SUMS( JA, JW ) = SUMS( JA, JW ) +
+     $                                   S( JR, J+JA-1 )*
+     $                                   WORK( ( JW+1 )*N+JR )
+                        SUMP( JA, JW ) = SUMP( JA, JW ) +
+     $                                   P( JR, J+JA-1 )*
+     $                                   WORK( ( JW+1 )*N+JR )
+  100                CONTINUE
+  110             CONTINUE
+  120          CONTINUE
+*
+*$PL$ CMCHAR=' '
+CDIR$          NEXTSCALAR
+C$DIR          SCALAR
+CDIR$          NEXT SCALAR
+CVD$L          NOVECTOR
+CDEC$          NOVECTOR
+CVD$           NOVECTOR
+*VDIR          NOVECTOR
+*VOCL          LOOP,SCALAR
+CIBM           PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+               DO 130 JA = 1, NA
+                  IF( ILCPLX ) THEN
+                     SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+     $                              BCOEFR*SUMP( JA, 1 ) -
+     $                              BCOEFI*SUMP( JA, 2 )
+                     SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
+     $                              BCOEFR*SUMP( JA, 2 ) +
+     $                              BCOEFI*SUMP( JA, 1 )
+                  ELSE
+                     SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+     $                              BCOEFR*SUMP( JA, 1 )
+                  END IF
+  130          CONTINUE
+*
+*                                  T
+*              Solve  ( a A - b B )  y = SUM(,)
+*              with scaling and perturbation of the denominator
+*
+               CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
+     $                      BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
+     $                      BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
+     $                      IINFO )
+               IF( SCALE.LT.ONE ) THEN
+                  DO 150 JW = 0, NW - 1
+                     DO 140 JR = JE, J - 1
+                        WORK( ( JW+2 )*N+JR ) = SCALE*
+     $                     WORK( ( JW+2 )*N+JR )
+  140                CONTINUE
+  150             CONTINUE
+                  XMAX = SCALE*XMAX
+               END IF
+               XMAX = MAX( XMAX, TEMP )
+  160       CONTINUE
+*
+*           Copy eigenvector to VL, back transforming if
+*           HOWMNY='B'.
+*
+            IEIG = IEIG + 1
+            IF( ILBACK ) THEN
+               DO 170 JW = 0, NW - 1
+                  CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
+     $                        WORK( ( JW+2 )*N+JE ), 1, ZERO,
+     $                        WORK( ( JW+4 )*N+1 ), 1 )
+  170          CONTINUE
+               CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
+     $                      LDVL )
+               IBEG = 1
+            ELSE
+               CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
+     $                      LDVL )
+               IBEG = JE
+            END IF
+*
+*           Scale eigenvector
+*
+            XMAX = ZERO
+            IF( ILCPLX ) THEN
+               DO 180 J = IBEG, N
+                  XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
+     $                   ABS( VL( J, IEIG+1 ) ) )
+  180          CONTINUE
+            ELSE
+               DO 190 J = IBEG, N
+                  XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
+  190          CONTINUE
+            END IF
+*
+            IF( XMAX.GT.SAFMIN ) THEN
+               XSCALE = ONE / XMAX
+*
+               DO 210 JW = 0, NW - 1
+                  DO 200 JR = IBEG, N
+                     VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
+  200             CONTINUE
+  210          CONTINUE
+            END IF
+            IEIG = IEIG + NW - 1
+*
+  220    CONTINUE
+      END IF
+*
+*     Right eigenvectors
+*
+      IF( COMPR ) THEN
+         IEIG = IM + 1
+*
+*        Main loop over eigenvalues
+*
+         ILCPLX = .FALSE.
+         DO 500 JE = N, 1, -1
+*
+*           Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+*           (b) this would be the second of a complex pair.
+*           Check for complex eigenvalue, so as to be sure of which
+*           entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
+*           or SELECT(JE-1).
+*           If this is a complex pair, the 2-by-2 diagonal block
+*           corresponding to the eigenvalue is in rows/columns JE-1:JE
+*
+            IF( ILCPLX ) THEN
+               ILCPLX = .FALSE.
+               GO TO 500
+            END IF
+            NW = 1
+            IF( JE.GT.1 ) THEN
+               IF( S( JE, JE-1 ).NE.ZERO ) THEN
+                  ILCPLX = .TRUE.
+                  NW = 2
+               END IF
+            END IF
+            IF( ILALL ) THEN
+               ILCOMP = .TRUE.
+            ELSE IF( ILCPLX ) THEN
+               ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
+            ELSE
+               ILCOMP = SELECT( JE )
+            END IF
+            IF( .NOT.ILCOMP )
+     $         GO TO 500
+*
+*           Decide if (a) singular pencil, (b) real eigenvalue, or
+*           (c) complex eigenvalue.
+*
+            IF( .NOT.ILCPLX ) THEN
+               IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+     $             ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+*                 Singular matrix pencil -- unit eigenvector
+*
+                  IEIG = IEIG - 1
+                  DO 230 JR = 1, N
+                     VR( JR, IEIG ) = ZERO
+  230             CONTINUE
+                  VR( IEIG, IEIG ) = ONE
+                  GO TO 500
+               END IF
+            END IF
+*
+*           Clear vector
+*
+            DO 250 JW = 0, NW - 1
+               DO 240 JR = 1, N
+                  WORK( ( JW+2 )*N+JR ) = ZERO
+  240          CONTINUE
+  250       CONTINUE
+*
+*           Compute coefficients in  ( a A - b B ) x = 0
+*              a  is  ACOEF
+*              b  is  BCOEFR + i*BCOEFI
+*
+            IF( .NOT.ILCPLX ) THEN
+*
+*              Real eigenvalue
+*
+               TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+     $                ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+               SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+               ACOEF = SBETA*ASCALE
+               BCOEFR = SALFAR*BSCALE
+               BCOEFI = ZERO
+*
+*              Scale to avoid underflow
+*
+               SCALE = ONE
+               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+               LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+     $               SMALL
+               IF( LSA )
+     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+               IF( LSB )
+     $            SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+     $                    MIN( BNORM, BIG ) )
+               IF( LSA .OR. LSB ) THEN
+                  SCALE = MIN( SCALE, ONE /
+     $                    ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+     $                    ABS( BCOEFR ) ) ) )
+                  IF( LSA ) THEN
+                     ACOEF = ASCALE*( SCALE*SBETA )
+                  ELSE
+                     ACOEF = SCALE*ACOEF
+                  END IF
+                  IF( LSB ) THEN
+                     BCOEFR = BSCALE*( SCALE*SALFAR )
+                  ELSE
+                     BCOEFR = SCALE*BCOEFR
+                  END IF
+               END IF
+               ACOEFA = ABS( ACOEF )
+               BCOEFA = ABS( BCOEFR )
+*
+*              First component is 1
+*
+               WORK( 2*N+JE ) = ONE
+               XMAX = ONE
+*
+*              Compute contribution from column JE of A and B to sum
+*              (See "Further Details", above.)
+*
+               DO 260 JR = 1, JE - 1
+                  WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
+     $                             ACOEF*S( JR, JE )
+  260          CONTINUE
+            ELSE
+*
+*              Complex eigenvalue
+*
+               CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
+     $                     SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+     $                     BCOEFI )
+               IF( BCOEFI.EQ.ZERO ) THEN
+                  INFO = JE - 1
+                  RETURN
+               END IF
+*
+*              Scale to avoid over/underflow
+*
+               ACOEFA = ABS( ACOEF )
+               BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+               SCALE = ONE
+               IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+     $            SCALE = ( SAFMIN / ULP ) / ACOEFA
+               IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+     $            SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+               IF( SAFMIN*ACOEFA.GT.ASCALE )
+     $            SCALE = ASCALE / ( SAFMIN*ACOEFA )
+               IF( SAFMIN*BCOEFA.GT.BSCALE )
+     $            SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+               IF( SCALE.NE.ONE ) THEN
+                  ACOEF = SCALE*ACOEF
+                  ACOEFA = ABS( ACOEF )
+                  BCOEFR = SCALE*BCOEFR
+                  BCOEFI = SCALE*BCOEFI
+                  BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+               END IF
+*
+*              Compute first two components of eigenvector
+*              and contribution to sums
+*
+               TEMP = ACOEF*S( JE, JE-1 )
+               TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+               TEMP2I = -BCOEFI*P( JE, JE )
+               IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+                  WORK( 2*N+JE ) = ONE
+                  WORK( 3*N+JE ) = ZERO
+                  WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
+                  WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
+               ELSE
+                  WORK( 2*N+JE-1 ) = ONE
+                  WORK( 3*N+JE-1 ) = ZERO
+                  TEMP = ACOEF*S( JE-1, JE )
+                  WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
+     $                             S( JE-1, JE-1 ) ) / TEMP
+                  WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
+               END IF
+*
+               XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+     $                ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
+*
+*              Compute contribution from columns JE and JE-1
+*              of A and B to the sums.
+*
+               CREALA = ACOEF*WORK( 2*N+JE-1 )
+               CIMAGA = ACOEF*WORK( 3*N+JE-1 )
+               CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
+     $                  BCOEFI*WORK( 3*N+JE-1 )
+               CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
+     $                  BCOEFR*WORK( 3*N+JE-1 )
+               CRE2A = ACOEF*WORK( 2*N+JE )
+               CIM2A = ACOEF*WORK( 3*N+JE )
+               CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
+               CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
+               DO 270 JR = 1, JE - 2
+                  WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
+     $                             CREALB*P( JR, JE-1 ) -
+     $                             CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
+                  WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
+     $                             CIMAGB*P( JR, JE-1 ) -
+     $                             CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
+  270          CONTINUE
+            END IF
+*
+            DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+*           Columnwise triangular solve of  (a A - b B)  x = 0
+*
+            IL2BY2 = .FALSE.
+            DO 370 J = JE - NW, 1, -1
+*
+*              If a 2-by-2 block, is in position j-1:j, wait until
+*              next iteration to process it (when it will be j:j+1)
+*
+               IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
+                  IF( S( J, J-1 ).NE.ZERO ) THEN
+                     IL2BY2 = .TRUE.
+                     GO TO 370
+                  END IF
+               END IF
+               BDIAG( 1 ) = P( J, J )
+               IF( IL2BY2 ) THEN
+                  NA = 2
+                  BDIAG( 2 ) = P( J+1, J+1 )
+               ELSE
+                  NA = 1
+               END IF
+*
+*              Compute x(j) (and x(j+1), if 2-by-2 block)
+*
+               CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
+     $                      LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
+     $                      N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
+     $                      IINFO )
+               IF( SCALE.LT.ONE ) THEN
+*
+                  DO 290 JW = 0, NW - 1
+                     DO 280 JR = 1, JE
+                        WORK( ( JW+2 )*N+JR ) = SCALE*
+     $                     WORK( ( JW+2 )*N+JR )
+  280                CONTINUE
+  290             CONTINUE
+               END IF
+               XMAX = MAX( SCALE*XMAX, TEMP )
+*
+               DO 310 JW = 1, NW
+                  DO 300 JA = 1, NA
+                     WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
+  300             CONTINUE
+  310          CONTINUE
+*
+*              w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
+*
+               IF( J.GT.1 ) THEN
+*
+*                 Check whether scaling is necessary for sum.
+*
+                  XSCALE = ONE / MAX( ONE, XMAX )
+                  TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
+                  IF( IL2BY2 )
+     $               TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
+     $                      WORK( N+J+1 ) )
+                  TEMP = MAX( TEMP, ACOEFA, BCOEFA )
+                  IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+*
+                     DO 330 JW = 0, NW - 1
+                        DO 320 JR = 1, JE
+                           WORK( ( JW+2 )*N+JR ) = XSCALE*
+     $                        WORK( ( JW+2 )*N+JR )
+  320                   CONTINUE
+  330                CONTINUE
+                     XMAX = XMAX*XSCALE
+                  END IF
+*
+*                 Compute the contributions of the off-diagonals of
+*                 column j (and j+1, if 2-by-2 block) of A and B to the
+*                 sums.
+*
+*
+                  DO 360 JA = 1, NA
+                     IF( ILCPLX ) THEN
+                        CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+                        CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
+                        CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
+     $                           BCOEFI*WORK( 3*N+J+JA-1 )
+                        CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
+     $                           BCOEFR*WORK( 3*N+J+JA-1 )
+                        DO 340 JR = 1, J - 1
+                           WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+     $                                      CREALA*S( JR, J+JA-1 ) +
+     $                                      CREALB*P( JR, J+JA-1 )
+                           WORK( 3*N+JR ) = WORK( 3*N+JR ) -
+     $                                      CIMAGA*S( JR, J+JA-1 ) +
+     $                                      CIMAGB*P( JR, J+JA-1 )
+  340                   CONTINUE
+                     ELSE
+                        CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+                        CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
+                        DO 350 JR = 1, J - 1
+                           WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+     $                                      CREALA*S( JR, J+JA-1 ) +
+     $                                      CREALB*P( JR, J+JA-1 )
+  350                   CONTINUE
+                     END IF
+  360             CONTINUE
+               END IF
+*
+               IL2BY2 = .FALSE.
+  370       CONTINUE
+*
+*           Copy eigenvector to VR, back transforming if
+*           HOWMNY='B'.
+*
+            IEIG = IEIG - NW
+            IF( ILBACK ) THEN
+*
+               DO 410 JW = 0, NW - 1
+                  DO 380 JR = 1, N
+                     WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
+     $                                       VR( JR, 1 )
+  380             CONTINUE
+*
+*                 A series of compiler directives to defeat
+*                 vectorization for the next loop
+*
+*
+                  DO 400 JC = 2, JE
+                     DO 390 JR = 1, N
+                        WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
+     $                     WORK( ( JW+2 )*N+JC )*VR( JR, JC )
+  390                CONTINUE
+  400             CONTINUE
+  410          CONTINUE
+*
+               DO 430 JW = 0, NW - 1
+                  DO 420 JR = 1, N
+                     VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
+  420             CONTINUE
+  430          CONTINUE
+*
+               IEND = N
+            ELSE
+               DO 450 JW = 0, NW - 1
+                  DO 440 JR = 1, N
+                     VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
+  440             CONTINUE
+  450          CONTINUE
+*
+               IEND = JE
+            END IF
+*
+*           Scale eigenvector
+*
+            XMAX = ZERO
+            IF( ILCPLX ) THEN
+               DO 460 J = 1, IEND
+                  XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
+     $                   ABS( VR( J, IEIG+1 ) ) )
+  460          CONTINUE
+            ELSE
+               DO 470 J = 1, IEND
+                  XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
+  470          CONTINUE
+            END IF
+*
+            IF( XMAX.GT.SAFMIN ) THEN
+               XSCALE = ONE / XMAX
+               DO 490 JW = 0, NW - 1
+                  DO 480 JR = 1, IEND
+                     VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
+  480             CONTINUE
+  490          CONTINUE
+            END IF
+  500    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DTGEVC
+*
+      END
diff --git a/src/lib/lapack/dtgex2.f b/src/lib/lapack/dtgex2.f
new file mode 100644
index 00000000..8351b7fd
--- /dev/null
+++ b/src/lib/lapack/dtgex2.f
@@ -0,0 +1,581 @@
+      SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, J1, N1, N2, WORK, LWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
+*  of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
+*  (A, B) by an orthogonal equivalence transformation.
+*
+*  (A, B) must be in generalized real Schur canonical form (as returned
+*  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+*  diagonal blocks. B is upper triangular.
+*
+*  Optionally, the matrices Q and Z of generalized Schur vectors are
+*  updated.
+*
+*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+*  Arguments
+*  =========
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A      (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N)
+*          On entry, the matrix A in the pair (A, B).
+*          On exit, the updated matrix A.
+*
+*  LDA     (input)  INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B      (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N)
+*          On entry, the matrix B in the pair (A, B).
+*          On exit, the updated matrix B.
+*
+*  LDB     (input)  INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+*          On exit, the updated matrix Q.
+*          Not referenced if WANTQ = .FALSE..
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= 1.
+*          If WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
+*          On exit, the updated matrix Z.
+*          Not referenced if WANTZ = .FALSE..
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1.
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  J1      (input) INTEGER
+*          The index to the first block (A11, B11). 1 <= J1 <= N.
+*
+*  N1      (input) INTEGER
+*          The order of the first block (A11, B11). N1 = 0, 1 or 2.
+*
+*  N2      (input) INTEGER
+*          The order of the second block (A22, B22). N2 = 0, 1 or 2.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >=  MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )
+*
+*  INFO    (output) INTEGER
+*            =0: Successful exit
+*            >0: If INFO = 1, the transformed matrix (A, B) would be
+*                too far from generalized Schur form; the blocks are
+*                not swapped and (A, B) and (Q, Z) are unchanged.
+*                The problem of swapping is too ill-conditioned.
+*            <0: If INFO = -16: LWORK is too small. Appropriate value
+*                for LWORK is returned in WORK(1).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  In the current code both weak and strong stability tests are
+*  performed. The user can omit the strong stability test by changing
+*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
+*  details.
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+*      Estimation: Theory, Algorithms and Software,
+*      Report UMINF - 94.04, Department of Computing Science, Umea
+*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+*      Note 87. To appear in Numerical Algorithms, 1996.
+*
+*  =====================================================================
+*  Replaced various illegal calls to DCOPY by calls to DLASET, or by DO
+*  loops. Sven Hammarling, 1/5/02.
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 1.0D+01 )
+      INTEGER            LDST
+      PARAMETER          ( LDST = 4 )
+      LOGICAL            WANDS
+      PARAMETER          ( WANDS = .TRUE. )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DTRONG, WEAK
+      INTEGER            I, IDUM, LINFO, M
+      DOUBLE PRECISION   BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
+     $                   F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IWORK( LDST )
+      DOUBLE PRECISION   AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
+     $                   IRCOP( LDST, LDST ), LI( LDST, LDST ),
+     $                   LICOP( LDST, LDST ), S( LDST, LDST ),
+     $                   SCPY( LDST, LDST ), T( LDST, LDST ),
+     $                   TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG,
+     $                   DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2,
+     $                   DROT, DSCAL, DTGSY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
+     $   RETURN
+      IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
+     $   RETURN
+      M = N1 + N2
+      IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN
+         INFO = -16
+         WORK( 1 ) = MAX( 1, N*M, M*M*2 )
+         RETURN
+      END IF
+*
+      WEAK = .FALSE.
+      DTRONG = .FALSE.
+*
+*     Make a local copy of selected block
+*
+      CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
+      CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
+      CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+      CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+*     Compute threshold for testing acceptance of swapping.
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      DSCALE = ZERO
+      DSUM = ONE
+      CALL DLACPY( 'Full', M, M, S, LDST, WORK, M )
+      CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+      CALL DLACPY( 'Full', M, M, T, LDST, WORK, M )
+      CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+      DNORM = DSCALE*SQRT( DSUM )
+      THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+      IF( M.EQ.2 ) THEN
+*
+*        CASE 1: Swap 1-by-1 and 1-by-1 blocks.
+*
+*        Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
+*        using Givens rotations and perform the swap tentatively.
+*
+         F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
+         G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
+         SB = ABS( T( 2, 2 ) )
+         SA = ABS( S( 2, 2 ) )
+         CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
+         IR( 2, 1 ) = -IR( 1, 2 )
+         IR( 2, 2 ) = IR( 1, 1 )
+         CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         IF( SA.GE.SB ) THEN
+            CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+     $                   DDUM )
+         ELSE
+            CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+     $                   DDUM )
+         END IF
+         CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
+     $              LI( 2, 1 ) )
+         CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
+     $              LI( 2, 1 ) )
+         LI( 2, 2 ) = LI( 1, 1 )
+         LI( 1, 2 ) = -LI( 2, 1 )
+*
+*        Weak stability test:
+*           |S21| + |T21| <= O(EPS * F-norm((S, T)))
+*
+         WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
+         WEAK = WS.LE.THRESH
+         IF( .NOT.WEAK )
+     $      GO TO 70
+*
+         IF( WANDS ) THEN
+*
+*           Strong stability test:
+*             F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
+*
+            CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+     $                   M )
+            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $                  WORK, M )
+            CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            DSCALE = ZERO
+            DSUM = ONE
+            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+            CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+     $                   M )
+            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $                  WORK, M )
+            CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+            SS = DSCALE*SQRT( DSUM )
+            DTRONG = SS.LE.THRESH
+            IF( .NOT.DTRONG )
+     $         GO TO 70
+         END IF
+*
+*        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+*               (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+         CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
+     $              IR( 2, 1 ) )
+         CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
+     $              LI( 1, 1 ), LI( 2, 1 ) )
+         CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
+     $              LI( 1, 1 ), LI( 2, 1 ) )
+*
+*        Set  N1-by-N2 (2,1) - blocks to ZERO.
+*
+         A( J1+1, J1 ) = ZERO
+         B( J1+1, J1 ) = ZERO
+*
+*        Accumulate transformations into Q and Z if requested.
+*
+         IF( WANTZ )
+     $      CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
+     $                 IR( 2, 1 ) )
+         IF( WANTQ )
+     $      CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
+     $                 LI( 2, 1 ) )
+*
+*        Exit with INFO = 0 if swap was successfully performed.
+*
+         RETURN
+*
+      ELSE
+*
+*        CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
+*                and 2-by-2 blocks.
+*
+*        Solve the generalized Sylvester equation
+*                 S11 * R - L * S22 = SCALE * S12
+*                 T11 * R - L * T22 = SCALE * T12
+*        for R and L. Solutions in LI and IR.
+*
+         CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
+         CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
+     $                IR( N2+1, N1+1 ), LDST )
+         CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
+     $                IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
+     $                LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
+     $                LINFO )
+*
+*        Compute orthogonal matrix QL:
+*
+*                    QL' * LI = [ TL ]
+*                               [ 0  ]
+*        where
+*                    LI =  [      -L              ]
+*                          [ SCALE * identity(N2) ]
+*
+         DO 10 I = 1, N2
+            CALL DSCAL( N1, -ONE, LI( 1, I ), 1 )
+            LI( N1+I, I ) = SCALE
+   10    CONTINUE
+         CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+*
+*        Compute orthogonal matrix RQ:
+*
+*                    IR * RQ' =   [ 0  TR],
+*
+*         where IR = [ SCALE * identity(N1), R ]
+*
+         DO 20 I = 1, N1
+            IR( N2+I, I ) = SCALE
+   20    CONTINUE
+         CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+*
+*        Perform the swapping tentatively:
+*
+         CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $               WORK, M )
+         CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
+     $               LDST )
+         CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $               WORK, M )
+         CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
+     $               LDST )
+         CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST )
+         CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST )
+         CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
+         CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
+*
+*        Triangularize the B-part by an RQ factorization.
+*        Apply transformation (from left) to A-part, giving S.
+*
+         CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
+     $                LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK,
+     $                LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+*
+*        Compute F-norm(S21) in BRQA21. (T21 is 0.)
+*
+         DSCALE = ZERO
+         DSUM = ONE
+         DO 30 I = 1, N2
+            CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
+   30    CONTINUE
+         BRQA21 = DSCALE*SQRT( DSUM )
+*
+*        Triangularize the B-part by a QR factorization.
+*        Apply transformation (from right) to A-part, giving S.
+*
+         CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+         CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
+     $                WORK, INFO )
+         CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST,
+     $                WORK, INFO )
+         IF( LINFO.NE.0 )
+     $      GO TO 70
+*
+*        Compute F-norm(S21) in BQRA21. (T21 is 0.)
+*
+         DSCALE = ZERO
+         DSUM = ONE
+         DO 40 I = 1, N2
+            CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
+   40    CONTINUE
+         BQRA21 = DSCALE*SQRT( DSUM )
+*
+*        Decide which method to use.
+*          Weak stability test:
+*             F-norm(S21) <= O(EPS * F-norm((S, T)))
+*
+         IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
+            CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST )
+            CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST )
+            CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
+            CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
+         ELSE IF( BRQA21.GE.THRESH ) THEN
+            GO TO 70
+         END IF
+*
+*        Set lower triangle of B-part to zero
+*
+         CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
+*
+         IF( WANDS ) THEN
+*
+*           Strong stability test:
+*              F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
+*
+            CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+     $                   M )
+            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+     $                  WORK, M )
+            CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            DSCALE = ZERO
+            DSUM = ONE
+            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+            CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+     $                   M )
+            CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+     $                  WORK, M )
+            CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+     $                  WORK( M*M+1 ), M )
+            CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+            SS = DSCALE*SQRT( DSUM )
+            DTRONG = ( SS.LE.THRESH )
+            IF( .NOT.DTRONG )
+     $         GO TO 70
+*
+         END IF
+*
+*        If the swap is accepted ("weakly" and "strongly"), apply the
+*        transformations and set N1-by-N2 (2,1)-block to zero.
+*
+         CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
+*
+*        copy back M-by-M diagonal block starting at index J1 of (A, B)
+*
+         CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
+         CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
+         CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
+*
+*        Standardize existing 2-by-2 blocks.
+*
+         DO 50 I = 1, M*M
+            WORK(I) = ZERO
+   50    CONTINUE
+         WORK( 1 ) = ONE
+         T( 1, 1 ) = ONE
+         IDUM = LWORK - M*M - 2
+         IF( N2.GT.1 ) THEN
+            CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE,
+     $                   WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
+            WORK( M+1 ) = -WORK( 2 )
+            WORK( M+2 ) = WORK( 1 )
+            T( N2, N2 ) = T( 1, 1 )
+            T( 1, 2 ) = -T( 2, 1 )
+         END IF
+         WORK( M*M ) = ONE
+         T( M, M ) = ONE
+*
+         IF( N1.GT.1 ) THEN
+            CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB,
+     $                   TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
+     $                   WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
+     $                   T( M, M-1 ) )
+            WORK( M*M ) = WORK( N2*M+N2+1 )
+            WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
+            T( M, M ) = T( N2+1, N2+1 )
+            T( M-1, M ) = -T( M, M-1 )
+         END IF
+         CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
+     $               LDA, ZERO, WORK( M*M+1 ), N2 )
+         CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
+     $                LDA )
+         CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
+     $               LDB, ZERO, WORK( M*M+1 ), N2 )
+         CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
+     $                LDB )
+         CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
+     $               WORK( M*M+1 ), M )
+         CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
+         CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
+     $               T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+         CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
+         CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
+     $               T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+         CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
+         CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
+     $               WORK, M )
+         CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST )
+*
+*        Accumulate transformations into Q and Z if requested.
+*
+         IF( WANTQ ) THEN
+            CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
+     $                  LDST, ZERO, WORK, N )
+            CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
+*
+         END IF
+*
+         IF( WANTZ ) THEN
+            CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
+     $                  LDST, ZERO, WORK, N )
+            CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
+*
+         END IF
+*
+*        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+*                (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+         I = J1 + M
+         IF( I.LE.N ) THEN
+            CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+     $                  A( J1, I ), LDA, ZERO, WORK, M )
+            CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
+            CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+     $                  B( J1, I ), LDA, ZERO, WORK, M )
+            CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
+         END IF
+         I = J1 - 1
+         IF( I.GT.0 ) THEN
+            CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
+     $                  LDST, ZERO, WORK, I )
+            CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
+            CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
+     $                  LDST, ZERO, WORK, I )
+            CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
+         END IF
+*
+*        Exit with INFO = 0 if swap was successfully performed.
+*
+         RETURN
+*
+      END IF
+*
+*     Exit with INFO = 1 if swap was rejected.
+*
+   70 CONTINUE
+*
+      INFO = 1
+      RETURN
+*
+*     End of DTGEX2
+*
+      END
diff --git a/src/lib/lapack/dtgexc.f b/src/lib/lapack/dtgexc.f
new file mode 100644
index 00000000..bafefea2
--- /dev/null
+++ b/src/lib/lapack/dtgexc.f
@@ -0,0 +1,440 @@
+      SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, IFST, ILST, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGEXC reorders the generalized real Schur decomposition of a real
+*  matrix pair (A,B) using an orthogonal equivalence transformation
+*
+*                 (A, B) = Q * (A, B) * Z',
+*
+*  so that the diagonal block of (A, B) with row index IFST is moved
+*  to row ILST.
+*
+*  (A, B) must be in generalized real Schur canonical form (as returned
+*  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+*  diagonal blocks. B is upper triangular.
+*
+*  Optionally, the matrices Q and Z of generalized Schur vectors are
+*  updated.
+*
+*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+*  Arguments
+*  =========
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the matrix A in generalized real Schur canonical
+*          form.
+*          On exit, the updated matrix A, again in generalized
+*          real Schur canonical form.
+*
+*  LDA     (input)  INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+*          On entry, the matrix B in generalized real Schur canonical
+*          form (A,B).
+*          On exit, the updated matrix B, again in generalized
+*          real Schur canonical form (A,B).
+*
+*  LDB     (input)  INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+*          On exit, the updated matrix Q.
+*          If WANTQ = .FALSE., Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= 1.
+*          If WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
+*          On exit, the updated matrix Z.
+*          If WANTZ = .FALSE., Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1.
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  IFST    (input/output) INTEGER
+*  ILST    (input/output) INTEGER
+*          Specify the reordering of the diagonal blocks of (A, B).
+*          The block with row index IFST is moved to row ILST, by a
+*          sequence of swapping between adjacent blocks.
+*          On exit, if IFST pointed on entry to the second row of
+*          a 2-by-2 block, it is changed to point to the first row;
+*          ILST always points to the first row of the block in its
+*          final position (which may differ from its input value by
+*          +1 or -1). 1 <= IFST, ILST <= N.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*           =0:  successful exit.
+*           <0:  if INFO = -i, the i-th argument had an illegal value.
+*           =1:  The transformed matrix pair (A, B) would be too far
+*                from generalized Schur form; the problem is ill-
+*                conditioned. (A, B) may have been partially reordered,
+*                and ILST points to the first row of the current
+*                position of the block being moved.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            HERE, LWMIN, NBF, NBL, NBNEXT
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTGEX2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input arguments.
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -11
+      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+         INFO = -12
+      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+         INFO = -13
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.LE.1 ) THEN
+            LWMIN = 1
+         ELSE
+            LWMIN = 4*N + 16
+         END IF
+         WORK(1) = LWMIN
+*
+         IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN
+            INFO = -15
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGEXC', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Determine the first row of the specified block and find out
+*     if it is 1-by-1 or 2-by-2.
+*
+      IF( IFST.GT.1 ) THEN
+         IF( A( IFST, IFST-1 ).NE.ZERO )
+     $      IFST = IFST - 1
+      END IF
+      NBF = 1
+      IF( IFST.LT.N ) THEN
+         IF( A( IFST+1, IFST ).NE.ZERO )
+     $      NBF = 2
+      END IF
+*
+*     Determine the first row of the final block
+*     and find out if it is 1-by-1 or 2-by-2.
+*
+      IF( ILST.GT.1 ) THEN
+         IF( A( ILST, ILST-1 ).NE.ZERO )
+     $      ILST = ILST - 1
+      END IF
+      NBL = 1
+      IF( ILST.LT.N ) THEN
+         IF( A( ILST+1, ILST ).NE.ZERO )
+     $      NBL = 2
+      END IF
+      IF( IFST.EQ.ILST )
+     $   RETURN
+*
+      IF( IFST.LT.ILST ) THEN
+*
+*        Update ILST.
+*
+         IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+     $      ILST = ILST - 1
+         IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+     $      ILST = ILST + 1
+*
+         HERE = IFST
+*
+   10    CONTINUE
+*
+*        Swap with next one below.
+*
+         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+*           Current block either 1-by-1 or 2-by-2.
+*
+            NBNEXT = 1
+            IF( HERE+NBF+1.LE.N ) THEN
+               IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            HERE = HERE + NBNEXT
+*
+*           Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+            IF( NBF.EQ.2 ) THEN
+               IF( A( HERE+1, HERE ).EQ.ZERO )
+     $            NBF = 3
+            END IF
+*
+         ELSE
+*
+*           Current block consists of two 1-by-1 blocks, each of which
+*           must be swapped individually.
+*
+            NBNEXT = 1
+            IF( HERE+3.LE.N ) THEN
+               IF( A( HERE+3, HERE+2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            IF( NBNEXT.EQ.1 ) THEN
+*
+*              Swap two 1-by-1 blocks.
+*
+               CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                      LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  ILST = HERE
+                  RETURN
+               END IF
+               HERE = HERE + 1
+*
+            ELSE
+*
+*              Recompute NBNEXT in case of 2-by-2 split.
+*
+               IF( A( HERE+2, HERE+1 ).EQ.ZERO )
+     $            NBNEXT = 1
+               IF( NBNEXT.EQ.2 ) THEN
+*
+*                 2-by-2 block did not split.
+*
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK,
+     $                         INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE + 2
+               ELSE
+*
+*                 2-by-2 block did split.
+*
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE + 1
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE + 1
+               END IF
+*
+            END IF
+         END IF
+         IF( HERE.LT.ILST )
+     $      GO TO 10
+      ELSE
+         HERE = IFST
+*
+   20    CONTINUE
+*
+*        Swap with next one below.
+*
+         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+*           Current block either 1-by-1 or 2-by-2.
+*
+            NBNEXT = 1
+            IF( HERE.GE.3 ) THEN
+               IF( A( HERE-1, HERE-2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK,
+     $                   INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            HERE = HERE - NBNEXT
+*
+*           Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+            IF( NBF.EQ.2 ) THEN
+               IF( A( HERE+1, HERE ).EQ.ZERO )
+     $            NBF = 3
+            END IF
+*
+         ELSE
+*
+*           Current block consists of two 1-by-1 blocks, each of which
+*           must be swapped individually.
+*
+            NBNEXT = 1
+            IF( HERE.GE.3 ) THEN
+               IF( A( HERE-1, HERE-2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK,
+     $                   INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            IF( NBNEXT.EQ.1 ) THEN
+*
+*              Swap two 1-by-1 blocks.
+*
+               CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                      LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
+               IF( INFO.NE.0 ) THEN
+                  ILST = HERE
+                  RETURN
+               END IF
+               HERE = HERE - 1
+            ELSE
+*
+*             Recompute NBNEXT in case of 2-by-2 split.
+*
+               IF( A( HERE, HERE-1 ).EQ.ZERO )
+     $            NBNEXT = 1
+               IF( NBNEXT.EQ.2 ) THEN
+*
+*                 2-by-2 block did not split.
+*
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE - 2
+               ELSE
+*
+*                 2-by-2 block did split.
+*
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE - 1
+                  CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE - 1
+               END IF
+            END IF
+         END IF
+         IF( HERE.GT.ILST )
+     $      GO TO 20
+      END IF
+      ILST = HERE
+      WORK( 1 ) = LWMIN
+      RETURN
+*
+*     End of DTGEXC
+*
+      END
diff --git a/src/lib/lapack/dtgsen.f b/src/lib/lapack/dtgsen.f
new file mode 100644
index 00000000..917a7b0f
--- /dev/null
+++ b/src/lib/lapack/dtgsen.f
@@ -0,0 +1,723 @@
+      SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
+     $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
+     $                   PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+     $                   M, N
+      DOUBLE PRECISION   PL, PR
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+     $                   B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
+     $                   WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGSEN reorders the generalized real Schur decomposition of a real
+*  matrix pair (A, B) (in terms of an orthonormal equivalence trans-
+*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
+*  appears in the leading diagonal blocks of the upper quasi-triangular
+*  matrix A and the upper triangular B. The leading columns of Q and
+*  Z form orthonormal bases of the corresponding left and right eigen-
+*  spaces (deflating subspaces). (A, B) must be in generalized real
+*  Schur canonical form (as returned by DGGES), i.e. A is block upper
+*  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
+*  triangular.
+*
+*  DTGSEN also computes the generalized eigenvalues
+*
+*              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
+*
+*  of the reordered matrix pair (A, B).
+*
+*  Optionally, DTGSEN computes the estimates of reciprocal condition
+*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
+*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
+*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to
+*  the selected cluster and the eigenvalues outside the cluster, resp.,
+*  and norms of "projections" onto left and right eigenspaces w.r.t.
+*  the selected cluster in the (1,1)-block.
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) INTEGER
+*          Specifies whether condition numbers are required for the
+*          cluster of eigenvalues (PL and PR) or the deflating subspaces
+*          (Difu and Difl):
+*           =0: Only reorder w.r.t. SELECT. No extras.
+*           =1: Reciprocal of norms of "projections" onto left and right
+*               eigenspaces w.r.t. the selected cluster (PL and PR).
+*           =2: Upper bounds on Difu and Difl. F-norm-based estimate
+*               (DIF(1:2)).
+*           =3: Estimate of Difu and Difl. 1-norm-based estimate
+*               (DIF(1:2)).
+*               About 5 times as expensive as IJOB = 2.
+*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
+*               version to get it all.
+*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          SELECT specifies the eigenvalues in the selected cluster.
+*          To select a real eigenvalue w(j), SELECT(j) must be set to
+*          .TRUE.. To select a complex conjugate pair of eigenvalues
+*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+*          either SELECT(j) or SELECT(j+1) or both must be set to
+*          .TRUE.; a complex conjugate pair of eigenvalues must be
+*          either both included in the cluster or both excluded.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension(LDA,N)
+*          On entry, the upper quasi-triangular matrix A, with (A, B) in
+*          generalized real Schur canonical form.
+*          On exit, A is overwritten by the reordered matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension(LDB,N)
+*          On entry, the upper triangular matrix B, with (A, B) in
+*          generalized real Schur canonical form.
+*          On exit, B is overwritten by the reordered matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
+*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
+*  BETA    (output) DOUBLE PRECISION array, dimension (N)
+*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
+*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
+*          form (S,T) that would result if the 2-by-2 diagonal blocks of
+*          the real generalized Schur form of (A,B) were further reduced
+*          to triangular form using complex unitary transformations.
+*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+*          positive, then the j-th and (j+1)-st eigenvalues are a
+*          complex conjugate pair, with ALPHAI(j+1) negative.
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
+*          On exit, Q has been postmultiplied by the left orthogonal
+*          transformation matrix which reorder (A, B); The leading M
+*          columns of Q form orthonormal bases for the specified pair of
+*          left eigenspaces (deflating subspaces).
+*          If WANTQ = .FALSE., Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= 1;
+*          and if WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
+*          On exit, Z has been postmultiplied by the left orthogonal
+*          transformation matrix which reorder (A, B); The leading M
+*          columns of Z form orthonormal bases for the specified pair of
+*          left eigenspaces (deflating subspaces).
+*          If WANTZ = .FALSE., Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1;
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  M       (output) INTEGER
+*          The dimension of the specified pair of left and right eigen-
+*          spaces (deflating subspaces). 0 <= M <= N.
+*
+*  PL      (output) DOUBLE PRECISION
+*  PR      (output) DOUBLE PRECISION
+*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
+*          reciprocal of the norm of "projections" onto left and right
+*          eigenspaces with respect to the selected cluster.
+*          0 < PL, PR <= 1.
+*          If M = 0 or M = N, PL = PR  = 1.
+*          If IJOB = 0, 2 or 3, PL and PR are not referenced.
+*
+*  DIF     (output) DOUBLE PRECISION array, dimension (2).
+*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
+*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
+*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
+*          estimates of Difu and Difl.
+*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
+*          If IJOB = 0 or 1, DIF is not referenced.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          IF IJOB = 0, WORK is not referenced.  Otherwise,
+*          on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >=  4*N+16.
+*          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
+*          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          IF IJOB = 0, IWORK is not referenced.  Otherwise,
+*          on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK. LIWORK >= 1.
+*          If IJOB = 1, 2 or 4, LIWORK >=  N+6.
+*          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*            =0: Successful exit.
+*            <0: If INFO = -i, the i-th argument had an illegal value.
+*            =1: Reordering of (A, B) failed because the transformed
+*                matrix pair (A, B) would be too far from generalized
+*                Schur form; the problem is very ill-conditioned.
+*                (A, B) may have been partially reordered.
+*                If requested, 0 is returned in DIF(*), PL and PR.
+*
+*  Further Details
+*  ===============
+*
+*  DTGSEN first collects the selected eigenvalues by computing
+*  orthogonal U and W that move them to the top left corner of (A, B).
+*  In other words, the selected eigenvalues are the eigenvalues of
+*  (A11, B11) in:
+*
+*                U'*(A, B)*W = (A11 A12) (B11 B12) n1
+*                              ( 0  A22),( 0  B22) n2
+*                                n1  n2    n1  n2
+*
+*  where N = n1+n2 and U' means the transpose of U. The first n1 columns
+*  of U and W span the specified pair of left and right eigenspaces
+*  (deflating subspaces) of (A, B).
+*
+*  If (A, B) has been obtained from the generalized real Schur
+*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
+*  reordered generalized real Schur form of (C, D) is given by
+*
+*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
+*
+*  and the first n1 columns of Q*U and Z*W span the corresponding
+*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
+*
+*  Note that if the selected eigenvalue is sufficiently ill-conditioned,
+*  then its value may differ significantly from its value before
+*  reordering.
+*
+*  The reciprocal condition numbers of the left and right eigenspaces
+*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
+*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
+*
+*  The Difu and Difl are defined as:
+*
+*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
+*  and
+*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
+*
+*  where sigma-min(Zu) is the smallest singular value of the
+*  (2*n1*n2)-by-(2*n1*n2) matrix
+*
+*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]
+*            [ kron(In2, B11)  -kron(B22', In1) ].
+*
+*  Here, Inx is the identity matrix of size nx and A22' is the
+*  transpose of A22. kron(X, Y) is the Kronecker product between
+*  the matrices X and Y.
+*
+*  When DIF(2) is small, small changes in (A, B) can cause large changes
+*  in the deflating subspace. An approximate (asymptotic) bound on the
+*  maximum angular error in the computed deflating subspaces is
+*
+*       EPS * norm((A, B)) / DIF(2),
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal norm of the projectors on the left and right
+*  eigenspaces associated with (A11, B11) may be returned in PL and PR.
+*  They are computed as follows. First we compute L and R so that
+*  P*(A, B)*Q is block diagonal, where
+*
+*       P = ( I -L ) n1           Q = ( I R ) n1
+*           ( 0  I ) n2    and        ( 0 I ) n2
+*             n1 n2                    n1 n2
+*
+*  and (L, R) is the solution to the generalized Sylvester equation
+*
+*       A11*R - L*A22 = -A12
+*       B11*R - L*B22 = -B12
+*
+*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
+*  An approximate (asymptotic) bound on the average absolute error of
+*  the selected eigenvalues is
+*
+*       EPS * norm((A, B)) / PL.
+*
+*  There are also global error bounds which valid for perturbations up
+*  to a certain restriction:  A lower bound (x) on the smallest
+*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
+*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
+*  (i.e. (A + E, B + F), is
+*
+*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
+*
+*  An approximate bound on x can be computed from DIF(1:2), PL and PR.
+*
+*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
+*  (L', R') and unperturbed (L, R) left and right deflating subspaces
+*  associated with the selected cluster in the (1,1)-blocks can be
+*  bounded as
+*
+*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
+*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
+*
+*  See LAPACK User's Guide section 4.11 or the following references
+*  for more information.
+*
+*  Note that if the default method for computing the Frobenius-norm-
+*  based estimate DIF is not wanted (see DLATDF), then the parameter
+*  IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
+*  (IJOB = 2 will be used)). See DTGSYL for more details.
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  References
+*  ==========
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+*      Estimation: Theory, Algorithms and Software,
+*      Report UMINF - 94.04, Department of Computing Science, Umea
+*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+*      Note 87. To appear in Numerical Algorithms, 1996.
+*
+*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+*      for Solving the Generalized Sylvester Equation and Estimating the
+*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
+*      1996.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IDIFJB
+      PARAMETER          ( IDIFJB = 3 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
+     $                   WANTP
+      INTEGER            I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
+     $                   MN2, N1, N2
+      DOUBLE PRECISION   DSCALE, DSUM, EPS, RDSCAL, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL,
+     $                   XERBLA
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -16
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSEN', -INFO )
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      IERR = 0
+*
+      WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
+      WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
+      WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
+      WANTD = WANTD1 .OR. WANTD2
+*
+*     Set M to the dimension of the specified pair of deflating
+*     subspaces.
+*
+      M = 0
+      PAIR = .FALSE.
+      DO 10 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+         ELSE
+            IF( K.LT.N ) THEN
+               IF( A( K+1, K ).EQ.ZERO ) THEN
+                  IF( SELECT( K ) )
+     $               M = M + 1
+               ELSE
+                  PAIR = .TRUE.
+                  IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $               M = M + 2
+               END IF
+            ELSE
+               IF( SELECT( N ) )
+     $            M = M + 1
+            END IF
+         END IF
+   10 CONTINUE
+*
+      IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+         LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) )
+         LIWMIN = MAX( 1, N+6 )
+      ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
+         LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) )
+         LIWMIN = MAX( 1, 2*M*( N-M ), N+6 )
+      ELSE
+         LWMIN = MAX( 1, 4*N+16 )
+         LIWMIN = 1
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -22
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -24
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSEN', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.N .OR. M.EQ.0 ) THEN
+         IF( WANTP ) THEN
+            PL = ONE
+            PR = ONE
+         END IF
+         IF( WANTD ) THEN
+            DSCALE = ZERO
+            DSUM = ONE
+            DO 20 I = 1, N
+               CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+               CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
+   20       CONTINUE
+            DIF( 1 ) = DSCALE*SQRT( DSUM )
+            DIF( 2 ) = DIF( 1 )
+         END IF
+         GO TO 60
+      END IF
+*
+*     Collect the selected blocks at the top-left corner of (A, B).
+*
+      KS = 0
+      PAIR = .FALSE.
+      DO 30 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+         ELSE
+*
+            SWAP = SELECT( K )
+            IF( K.LT.N ) THEN
+               IF( A( K+1, K ).NE.ZERO ) THEN
+                  PAIR = .TRUE.
+                  SWAP = SWAP .OR. SELECT( K+1 )
+               END IF
+            END IF
+*
+            IF( SWAP ) THEN
+               KS = KS + 1
+*
+*              Swap the K-th block to position KS.
+*              Perform the reordering of diagonal blocks in (A, B)
+*              by orthogonal transformation matrices and update
+*              Q and Z accordingly (if requested):
+*
+               KK = K
+               IF( K.NE.KS )
+     $            CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+     $                         Z, LDZ, KK, KS, WORK, LWORK, IERR )
+*
+               IF( IERR.GT.0 ) THEN
+*
+*                 Swap is rejected: exit.
+*
+                  INFO = 1
+                  IF( WANTP ) THEN
+                     PL = ZERO
+                     PR = ZERO
+                  END IF
+                  IF( WANTD ) THEN
+                     DIF( 1 ) = ZERO
+                     DIF( 2 ) = ZERO
+                  END IF
+                  GO TO 60
+               END IF
+*
+               IF( PAIR )
+     $            KS = KS + 1
+            END IF
+         END IF
+   30 CONTINUE
+      IF( WANTP ) THEN
+*
+*        Solve generalized Sylvester equation for R and L
+*        and compute PL and PR.
+*
+         N1 = M
+         N2 = N - M
+         I = N1 + 1
+         IJB = 0
+         CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+         CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+     $                N1 )
+         CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+     $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
+     $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
+     $                LWORK-2*N1*N2, IWORK, IERR )
+*
+*        Estimate the reciprocal of norms of "projections" onto left
+*        and right eigenspaces.
+*
+         RDSCAL = ZERO
+         DSUM = ONE
+         CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
+         PL = RDSCAL*SQRT( DSUM )
+         IF( PL.EQ.ZERO ) THEN
+            PL = ONE
+         ELSE
+            PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
+         END IF
+         RDSCAL = ZERO
+         DSUM = ONE
+         CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
+         PR = RDSCAL*SQRT( DSUM )
+         IF( PR.EQ.ZERO ) THEN
+            PR = ONE
+         ELSE
+            PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
+         END IF
+      END IF
+*
+      IF( WANTD ) THEN
+*
+*        Compute estimates of Difu and Difl.
+*
+         IF( WANTD1 ) THEN
+            N1 = M
+            N2 = N - M
+            I = N1 + 1
+            IJB = IDIFJB
+*
+*           Frobenius norm-based Difu-estimate.
+*
+            CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+     $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
+     $                   N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
+     $                   LWORK-2*N1*N2, IWORK, IERR )
+*
+*           Frobenius norm-based Difl-estimate.
+*
+            CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
+     $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
+     $                   N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
+     $                   LWORK-2*N1*N2, IWORK, IERR )
+         ELSE
+*
+*
+*           Compute 1-norm-based estimates of Difu and Difl using
+*           reversed communication with DLACN2. In each step a
+*           generalized Sylvester equation or a transposed variant
+*           is solved.
+*
+            KASE = 0
+            N1 = M
+            N2 = N - M
+            I = N1 + 1
+            IJB = 0
+            MN2 = 2*N1*N2
+*
+*           1-norm-based estimate of Difu.
+*
+   40       CONTINUE
+            CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
+     $                   KASE, ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation.
+*
+                  CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+     $                         WORK, N1, B, LDB, B( I, I ), LDB,
+     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+     $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               ELSE
+*
+*                 Solve the transposed variant.
+*
+                  CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+     $                         WORK, N1, B, LDB, B( I, I ), LDB,
+     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+     $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               END IF
+               GO TO 40
+            END IF
+            DIF( 1 ) = DSCALE / DIF( 1 )
+*
+*           1-norm-based estimate of Difl.
+*
+   50       CONTINUE
+            CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
+     $                   KASE, ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation.
+*
+                  CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+     $                         WORK, N2, B( I, I ), LDB, B, LDB,
+     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+     $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               ELSE
+*
+*                 Solve the transposed variant.
+*
+                  CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+     $                         WORK, N2, B( I, I ), LDB, B, LDB,
+     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+     $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               END IF
+               GO TO 50
+            END IF
+            DIF( 2 ) = DSCALE / DIF( 2 )
+*
+         END IF
+      END IF
+*
+   60 CONTINUE
+*
+*     Compute generalized eigenvalues of reordered pair (A, B) and
+*     normalize the generalized Schur form.
+*
+      PAIR = .FALSE.
+      DO 80 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+         ELSE
+*
+            IF( K.LT.N ) THEN
+               IF( A( K+1, K ).NE.ZERO ) THEN
+                  PAIR = .TRUE.
+               END IF
+            END IF
+*
+            IF( PAIR ) THEN
+*
+*             Compute the eigenvalue(s) at position K.
+*
+               WORK( 1 ) = A( K, K )
+               WORK( 2 ) = A( K+1, K )
+               WORK( 3 ) = A( K, K+1 )
+               WORK( 4 ) = A( K+1, K+1 )
+               WORK( 5 ) = B( K, K )
+               WORK( 6 ) = B( K+1, K )
+               WORK( 7 ) = B( K, K+1 )
+               WORK( 8 ) = B( K+1, K+1 )
+               CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
+     $                     BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
+     $                     ALPHAI( K ) )
+               ALPHAI( K+1 ) = -ALPHAI( K )
+*
+            ELSE
+*
+               IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
+*
+*                 If B(K,K) is negative, make it positive
+*
+                  DO 70 I = 1, N
+                     A( K, I ) = -A( K, I )
+                     B( K, I ) = -B( K, I )
+                     Q( I, K ) = -Q( I, K )
+   70             CONTINUE
+               END IF
+*
+               ALPHAR( K ) = A( K, K )
+               ALPHAI( K ) = ZERO
+               BETA( K ) = B( K, K )
+*
+            END IF
+         END IF
+   80 CONTINUE
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DTGSEN
+*
+      END
diff --git a/src/lib/lapack/dtgsy2.f b/src/lib/lapack/dtgsy2.f
new file mode 100644
index 00000000..3ebc912f
--- /dev/null
+++ b/src/lib/lapack/dtgsy2.f
@@ -0,0 +1,956 @@
+      SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
+     $                   IWORK, PQ, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
+     $                   PQ
+      DOUBLE PRECISION   RDSCAL, RDSUM, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGSY2 solves the generalized Sylvester equation:
+*
+*              A * R - L * B = scale * C                (1)
+*              D * R - L * E = scale * F,
+*
+*  using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
+*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
+*  N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
+*  must be in generalized Schur canonical form, i.e. A, B are upper
+*  quasi triangular and D, E are upper triangular. The solution (R, L)
+*  overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
+*  chosen to avoid overflow.
+*
+*  In matrix notation solving equation (1) corresponds to solve
+*  Z*x = scale*b, where Z is defined as
+*
+*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)
+*             [ kron(In, D)  -kron(E', Im) ],
+*
+*  Ik is the identity matrix of size k and X' is the transpose of X.
+*  kron(X, Y) is the Kronecker product between the matrices X and Y.
+*  In the process of solving (1), we solve a number of such systems
+*  where Dim(In), Dim(In) = 1 or 2.
+*
+*  If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
+*  which is equivalent to solve for R and L in
+*
+*              A' * R  + D' * L   = scale *  C           (3)
+*              R  * B' + L  * E'  = scale * -F
+*
+*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =
+*  sigma_min(Z) using reverse communicaton with DLACON.
+*
+*  DTGSY2 also (IJOB >= 1) contributes to the computation in STGSYL
+*  of an upper bound on the separation between to matrix pairs. Then
+*  the input (A, D), (B, E) are sub-pencils of the matrix pair in
+*  DTGSYL. See STGSYL for details.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N', solve the generalized Sylvester equation (1).
+*          = 'T': solve the 'transposed' system (3).
+*
+*  IJOB    (input) INTEGER
+*          Specifies what kind of functionality to be performed.
+*          = 0: solve (1) only.
+*          = 1: A contribution from this subsystem to a Frobenius
+*               norm-based estimate of the separation between two matrix
+*               pairs is computed. (look ahead strategy is used).
+*          = 2: A contribution from this subsystem to a Frobenius
+*               norm-based estimate of the separation between two matrix
+*               pairs is computed. (DGECON on sub-systems is used.)
+*          Not referenced if TRANS = 'T'.
+*
+*  M       (input) INTEGER
+*          On entry, M specifies the order of A and D, and the row
+*          dimension of C, F, R and L.
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the order of B and E, and the column
+*          dimension of C, F, R and L.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)
+*          On entry, A contains an upper quasi triangular matrix.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the matrix A. LDA >= max(1, M).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
+*          On entry, B contains an upper quasi triangular matrix.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the matrix B. LDB >= max(1, N).
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, N)
+*          On entry, C contains the right-hand-side of the first matrix
+*          equation in (1).
+*          On exit, if IJOB = 0, C has been overwritten by the
+*          solution R.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the matrix C. LDC >= max(1, M).
+*
+*  D       (input) DOUBLE PRECISION array, dimension (LDD, M)
+*          On entry, D contains an upper triangular matrix.
+*
+*  LDD     (input) INTEGER
+*          The leading dimension of the matrix D. LDD >= max(1, M).
+*
+*  E       (input) DOUBLE PRECISION array, dimension (LDE, N)
+*          On entry, E contains an upper triangular matrix.
+*
+*  LDE     (input) INTEGER
+*          The leading dimension of the matrix E. LDE >= max(1, N).
+*
+*  F       (input/output) DOUBLE PRECISION array, dimension (LDF, N)
+*          On entry, F contains the right-hand-side of the second matrix
+*          equation in (1).
+*          On exit, if IJOB = 0, F has been overwritten by the
+*          solution L.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the matrix F. LDF >= max(1, M).
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
+*          R and L (C and F on entry) will hold the solutions to a
+*          slightly perturbed system but the input matrices A, B, D and
+*          E have not been changed. If SCALE = 0, R and L will hold the
+*          solutions to the homogeneous system with C = F = 0. Normally,
+*          SCALE = 1.
+*
+*  RDSUM   (input/output) DOUBLE PRECISION
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by DTGSYL, where the
+*          scaling factor RDSCAL (see below) has been factored out.
+*          On exit, the corresponding sum of squares updated with the
+*          contributions from the current sub-system.
+*          If TRANS = 'T' RDSUM is not touched.
+*          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
+*
+*  RDSCAL  (input/output) DOUBLE PRECISION
+*          On entry, scaling factor used to prevent overflow in RDSUM.
+*          On exit, RDSCAL is updated w.r.t. the current contributions
+*          in RDSUM.
+*          If TRANS = 'T', RDSCAL is not touched.
+*          NOTE: RDSCAL only makes sense when DTGSY2 is called by
+*                DTGSYL.
+*
+*  IWORK   (workspace) INTEGER array, dimension (M+N+2)
+*
+*  PQ      (output) INTEGER
+*          On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
+*          8-by-8) solved by this routine.
+*
+*  INFO    (output) INTEGER
+*          On exit, if INFO is set to
+*            =0: Successful exit
+*            <0: If INFO = -i, the i-th argument had an illegal value.
+*            >0: The matrix pairs (A, D) and (B, E) have common or very
+*                close eigenvalues.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*  Replaced various illegal calls to DCOPY by calls to DLASET.
+*  Sven Hammarling, 27/5/02.
+*
+*     .. Parameters ..
+      INTEGER            LDZ
+      PARAMETER          ( LDZ = 8 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
+     $                   K, MB, NB, P, Q, ZDIM
+      DOUBLE PRECISION   ALPHA, SCALOC
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IPIV( LDZ ), JPIV( LDZ )
+      DOUBLE PRECISION   RHS( LDZ ), Z( LDZ, LDZ )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2,
+     $                   DGETC2, DLASET, DLATDF, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input parameters
+*
+      INFO = 0
+      IERR = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -1
+      ELSE IF( NOTRAN ) THEN
+         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
+            INFO = -2
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( M.LE.0 ) THEN
+            INFO = -3
+         ELSE IF( N.LE.0 ) THEN
+            INFO = -4
+         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+            INFO = -5
+         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+            INFO = -8
+         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+            INFO = -10
+         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+            INFO = -12
+         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+            INFO = -14
+         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSY2', -INFO )
+         RETURN
+      END IF
+*
+*     Determine block structure of A
+*
+      PQ = 0
+      P = 0
+      I = 1
+   10 CONTINUE
+      IF( I.GT.M )
+     $   GO TO 20
+      P = P + 1
+      IWORK( P ) = I
+      IF( I.EQ.M )
+     $   GO TO 20
+      IF( A( I+1, I ).NE.ZERO ) THEN
+         I = I + 2
+      ELSE
+         I = I + 1
+      END IF
+      GO TO 10
+   20 CONTINUE
+      IWORK( P+1 ) = M + 1
+*
+*     Determine block structure of B
+*
+      Q = P + 1
+      J = 1
+   30 CONTINUE
+      IF( J.GT.N )
+     $   GO TO 40
+      Q = Q + 1
+      IWORK( Q ) = J
+      IF( J.EQ.N )
+     $   GO TO 40
+      IF( B( J+1, J ).NE.ZERO ) THEN
+         J = J + 2
+      ELSE
+         J = J + 1
+      END IF
+      GO TO 30
+   40 CONTINUE
+      IWORK( Q+1 ) = N + 1
+      PQ = P*( Q-P-1 )
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve (I, J) - subsystem
+*           A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+*           D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+*        for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
+*
+         SCALE = ONE
+         SCALOC = ONE
+         DO 120 J = P + 2, Q
+            JS = IWORK( J )
+            JSP1 = JS + 1
+            JE = IWORK( J+1 ) - 1
+            NB = JE - JS + 1
+            DO 110 I = P, 1, -1
+*
+               IS = IWORK( I )
+               ISP1 = IS + 1
+               IE = IWORK( I+1 ) - 1
+               MB = IE - IS + 1
+               ZDIM = MB*NB*2
+*
+               IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+*                 Build a 2-by-2 system Z * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = D( IS, IS )
+                  Z( 1, 2 ) = -B( JS, JS )
+                  Z( 2, 2 ) = -E( JS, JS )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = F( IS, JS )
+*
+*                 Solve Z * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 50 K = 1, N
+                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   50                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+     $                            RDSCAL, IPIV, JPIV )
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  F( IS, JS ) = RHS( 2 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     ALPHA = -RHS( 1 )
+                     CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
+     $                           1 )
+                     CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
+     $                           1 )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
+     $                           F( IS, JE+1 ), LDF )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build a 4-by-4 system Z * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = ZERO
+                  Z( 3, 1 ) = D( IS, IS )
+                  Z( 4, 1 ) = ZERO
+*
+                  Z( 1, 2 ) = ZERO
+                  Z( 2, 2 ) = A( IS, IS )
+                  Z( 3, 2 ) = ZERO
+                  Z( 4, 2 ) = D( IS, IS )
+*
+                  Z( 1, 3 ) = -B( JS, JS )
+                  Z( 2, 3 ) = -B( JS, JSP1 )
+                  Z( 3, 3 ) = -E( JS, JS )
+                  Z( 4, 3 ) = -E( JS, JSP1 )
+*
+                  Z( 1, 4 ) = -B( JSP1, JS )
+                  Z( 2, 4 ) = -B( JSP1, JSP1 )
+                  Z( 3, 4 ) = ZERO
+                  Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = C( IS, JSP1 )
+                  RHS( 3 ) = F( IS, JS )
+                  RHS( 4 ) = F( IS, JSP1 )
+*
+*                 Solve Z * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 60 K = 1, N
+                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   60                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+     $                            RDSCAL, IPIV, JPIV )
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  C( IS, JSP1 ) = RHS( 2 )
+                  F( IS, JS ) = RHS( 3 )
+                  F( IS, JSP1 ) = RHS( 4 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
+     $                          1, C( 1, JS ), LDC )
+                     CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
+     $                          1, F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
+     $                           F( IS, JE+1 ), LDF )
+                     CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
+     $                           F( IS, JE+1 ), LDF )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+*                 Build a 4-by-4 system Z * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = A( ISP1, IS )
+                  Z( 3, 1 ) = D( IS, IS )
+                  Z( 4, 1 ) = ZERO
+*
+                  Z( 1, 2 ) = A( IS, ISP1 )
+                  Z( 2, 2 ) = A( ISP1, ISP1 )
+                  Z( 3, 2 ) = D( IS, ISP1 )
+                  Z( 4, 2 ) = D( ISP1, ISP1 )
+*
+                  Z( 1, 3 ) = -B( JS, JS )
+                  Z( 2, 3 ) = ZERO
+                  Z( 3, 3 ) = -E( JS, JS )
+                  Z( 4, 3 ) = ZERO
+*
+                  Z( 1, 4 ) = ZERO
+                  Z( 2, 4 ) = -B( JS, JS )
+                  Z( 3, 4 ) = ZERO
+                  Z( 4, 4 ) = -E( JS, JS )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = C( ISP1, JS )
+                  RHS( 3 ) = F( IS, JS )
+                  RHS( 4 ) = F( ISP1, JS )
+*
+*                 Solve Z * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 70 K = 1, N
+                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   70                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+     $                            RDSCAL, IPIV, JPIV )
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  C( ISP1, JS ) = RHS( 2 )
+                  F( IS, JS ) = RHS( 3 )
+                  F( ISP1, JS ) = RHS( 4 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
+     $                           RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
+                     CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
+     $                           RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
+     $                          B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
+                     CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
+     $                          E( JS, JE+1 ), LDB, F( IS, JE+1 ), LDC )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build an 8-by-8 system Z * x = RHS
+*
+                  CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = A( ISP1, IS )
+                  Z( 5, 1 ) = D( IS, IS )
+*
+                  Z( 1, 2 ) = A( IS, ISP1 )
+                  Z( 2, 2 ) = A( ISP1, ISP1 )
+                  Z( 5, 2 ) = D( IS, ISP1 )
+                  Z( 6, 2 ) = D( ISP1, ISP1 )
+*
+                  Z( 3, 3 ) = A( IS, IS )
+                  Z( 4, 3 ) = A( ISP1, IS )
+                  Z( 7, 3 ) = D( IS, IS )
+*
+                  Z( 3, 4 ) = A( IS, ISP1 )
+                  Z( 4, 4 ) = A( ISP1, ISP1 )
+                  Z( 7, 4 ) = D( IS, ISP1 )
+                  Z( 8, 4 ) = D( ISP1, ISP1 )
+*
+                  Z( 1, 5 ) = -B( JS, JS )
+                  Z( 3, 5 ) = -B( JS, JSP1 )
+                  Z( 5, 5 ) = -E( JS, JS )
+                  Z( 7, 5 ) = -E( JS, JSP1 )
+*
+                  Z( 2, 6 ) = -B( JS, JS )
+                  Z( 4, 6 ) = -B( JS, JSP1 )
+                  Z( 6, 6 ) = -E( JS, JS )
+                  Z( 8, 6 ) = -E( JS, JSP1 )
+*
+                  Z( 1, 7 ) = -B( JSP1, JS )
+                  Z( 3, 7 ) = -B( JSP1, JSP1 )
+                  Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+                  Z( 2, 8 ) = -B( JSP1, JS )
+                  Z( 4, 8 ) = -B( JSP1, JSP1 )
+                  Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+*                 Set up right hand side(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 80 JJ = 0, NB - 1
+                     CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+                     CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+                     K = K + MB
+                     II = II + MB
+   80             CONTINUE
+*
+*                 Solve Z * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  IF( IJOB.EQ.0 ) THEN
+                     CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+     $                            SCALOC )
+                     IF( SCALOC.NE.ONE ) THEN
+                        DO 90 K = 1, N
+                           CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                           CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   90                   CONTINUE
+                        SCALE = SCALE*SCALOC
+                     END IF
+                  ELSE
+                     CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+     $                            RDSCAL, IPIV, JPIV )
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 100 JJ = 0, NB - 1
+                     CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+                     CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+                     K = K + MB
+                     II = II + MB
+  100             CONTINUE
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
+     $                           C( 1, JS ), LDC )
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
+     $                           F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     K = MB*NB + 1
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+     $                           MB, B( JS, JE+1 ), LDB, ONE,
+     $                           C( IS, JE+1 ), LDC )
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+     $                           MB, E( JS, JE+1 ), LDE, ONE,
+     $                           F( IS, JE+1 ), LDF )
+                  END IF
+*
+               END IF
+*
+  110       CONTINUE
+  120    CONTINUE
+      ELSE
+*
+*        Solve (I, J) - subsystem
+*             A(I, I)' * R(I, J) + D(I, I)' * L(J, J)  =  C(I, J)
+*             R(I, I)  * B(J, J) + L(I, J)  * E(J, J)  = -F(I, J)
+*        for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
+*
+         SCALE = ONE
+         SCALOC = ONE
+         DO 200 I = 1, P
+*
+            IS = IWORK( I )
+            ISP1 = IS + 1
+            IE = ( I+1 ) - 1
+            MB = IE - IS + 1
+            DO 190 J = Q, P + 2, -1
+*
+               JS = IWORK( J )
+               JSP1 = JS + 1
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               ZDIM = MB*NB*2
+               IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+*                 Build a 2-by-2 system Z' * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = -B( JS, JS )
+                  Z( 1, 2 ) = D( IS, IS )
+                  Z( 2, 2 ) = -E( JS, JS )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = F( IS, JS )
+*
+*                 Solve Z' * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 130 K = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  130                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  F( IS, JS ) = RHS( 2 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( J.GT.P+2 ) THEN
+                     ALPHA = RHS( 1 )
+                     CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
+     $                           LDF )
+                     ALPHA = RHS( 2 )
+                     CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
+     $                           LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     ALPHA = -RHS( 1 )
+                     CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
+     $                           C( IE+1, JS ), 1 )
+                     ALPHA = -RHS( 2 )
+                     CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
+     $                           C( IE+1, JS ), 1 )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build a 4-by-4 system Z' * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = ZERO
+                  Z( 3, 1 ) = -B( JS, JS )
+                  Z( 4, 1 ) = -B( JSP1, JS )
+*
+                  Z( 1, 2 ) = ZERO
+                  Z( 2, 2 ) = A( IS, IS )
+                  Z( 3, 2 ) = -B( JS, JSP1 )
+                  Z( 4, 2 ) = -B( JSP1, JSP1 )
+*
+                  Z( 1, 3 ) = D( IS, IS )
+                  Z( 2, 3 ) = ZERO
+                  Z( 3, 3 ) = -E( JS, JS )
+                  Z( 4, 3 ) = ZERO
+*
+                  Z( 1, 4 ) = ZERO
+                  Z( 2, 4 ) = D( IS, IS )
+                  Z( 3, 4 ) = -E( JS, JSP1 )
+                  Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = C( IS, JSP1 )
+                  RHS( 3 ) = F( IS, JS )
+                  RHS( 4 ) = F( IS, JSP1 )
+*
+*                 Solve Z' * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 140 K = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  140                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  C( IS, JSP1 ) = RHS( 2 )
+                  F( IS, JS ) = RHS( 3 )
+                  F( IS, JSP1 ) = RHS( 4 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( J.GT.P+2 ) THEN
+                     CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
+     $                           F( IS, 1 ), LDF )
+                     CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
+     $                           F( IS, 1 ), LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
+     $                          RHS( 1 ), 1, C( IE+1, JS ), LDC )
+                     CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
+     $                          RHS( 3 ), 1, C( IE+1, JS ), LDC )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+*                 Build a 4-by-4 system Z' * x = RHS
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = A( IS, ISP1 )
+                  Z( 3, 1 ) = -B( JS, JS )
+                  Z( 4, 1 ) = ZERO
+*
+                  Z( 1, 2 ) = A( ISP1, IS )
+                  Z( 2, 2 ) = A( ISP1, ISP1 )
+                  Z( 3, 2 ) = ZERO
+                  Z( 4, 2 ) = -B( JS, JS )
+*
+                  Z( 1, 3 ) = D( IS, IS )
+                  Z( 2, 3 ) = D( IS, ISP1 )
+                  Z( 3, 3 ) = -E( JS, JS )
+                  Z( 4, 3 ) = ZERO
+*
+                  Z( 1, 4 ) = ZERO
+                  Z( 2, 4 ) = D( ISP1, ISP1 )
+                  Z( 3, 4 ) = ZERO
+                  Z( 4, 4 ) = -E( JS, JS )
+*
+*                 Set up right hand side(s)
+*
+                  RHS( 1 ) = C( IS, JS )
+                  RHS( 2 ) = C( ISP1, JS )
+                  RHS( 3 ) = F( IS, JS )
+                  RHS( 4 ) = F( ISP1, JS )
+*
+*                 Solve Z' * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 150 K = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  150                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  C( IS, JS ) = RHS( 1 )
+                  C( ISP1, JS ) = RHS( 2 )
+                  F( IS, JS ) = RHS( 3 )
+                  F( ISP1, JS ) = RHS( 4 )
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( J.GT.P+2 ) THEN
+                     CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
+     $                          1, F( IS, 1 ), LDF )
+                     CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
+     $                          1, F( IS, 1 ), LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
+     $                           LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
+     $                           1 )
+                     CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
+     $                           LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
+     $                           1 )
+                  END IF
+*
+               ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+*                 Build an 8-by-8 system Z' * x = RHS
+*
+                  CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+                  Z( 1, 1 ) = A( IS, IS )
+                  Z( 2, 1 ) = A( IS, ISP1 )
+                  Z( 5, 1 ) = -B( JS, JS )
+                  Z( 7, 1 ) = -B( JSP1, JS )
+*
+                  Z( 1, 2 ) = A( ISP1, IS )
+                  Z( 2, 2 ) = A( ISP1, ISP1 )
+                  Z( 6, 2 ) = -B( JS, JS )
+                  Z( 8, 2 ) = -B( JSP1, JS )
+*
+                  Z( 3, 3 ) = A( IS, IS )
+                  Z( 4, 3 ) = A( IS, ISP1 )
+                  Z( 5, 3 ) = -B( JS, JSP1 )
+                  Z( 7, 3 ) = -B( JSP1, JSP1 )
+*
+                  Z( 3, 4 ) = A( ISP1, IS )
+                  Z( 4, 4 ) = A( ISP1, ISP1 )
+                  Z( 6, 4 ) = -B( JS, JSP1 )
+                  Z( 8, 4 ) = -B( JSP1, JSP1 )
+*
+                  Z( 1, 5 ) = D( IS, IS )
+                  Z( 2, 5 ) = D( IS, ISP1 )
+                  Z( 5, 5 ) = -E( JS, JS )
+*
+                  Z( 2, 6 ) = D( ISP1, ISP1 )
+                  Z( 6, 6 ) = -E( JS, JS )
+*
+                  Z( 3, 7 ) = D( IS, IS )
+                  Z( 4, 7 ) = D( IS, ISP1 )
+                  Z( 5, 7 ) = -E( JS, JSP1 )
+                  Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+                  Z( 4, 8 ) = D( ISP1, ISP1 )
+                  Z( 6, 8 ) = -E( JS, JSP1 )
+                  Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+*                 Set up right hand side(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 160 JJ = 0, NB - 1
+                     CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+                     CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+                     K = K + MB
+                     II = II + MB
+  160             CONTINUE
+*
+*
+*                 Solve Z' * x = RHS
+*
+                  CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+                  IF( IERR.GT.0 )
+     $               INFO = IERR
+*
+                  CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 170 K = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  170                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Unpack solution vector(s)
+*
+                  K = 1
+                  II = MB*NB + 1
+                  DO 180 JJ = 0, NB - 1
+                     CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+                     CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+                     K = K + MB
+                     II = II + MB
+  180             CONTINUE
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( J.GT.P+2 ) THEN
+                     CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+     $                           C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
+     $                           F( IS, 1 ), LDF )
+                     CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+     $                           F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
+     $                           F( IS, 1 ), LDF )
+                  END IF
+                  IF( I.LT.P ) THEN
+                     CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                           A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
+     $                           ONE, C( IE+1, JS ), LDC )
+                     CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                           D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
+     $                           ONE, C( IE+1, JS ), LDC )
+                  END IF
+*
+               END IF
+*
+  190       CONTINUE
+  200    CONTINUE
+*
+      END IF
+      RETURN
+*
+*     End of DTGSY2
+*
+      END
diff --git a/src/lib/lapack/dtgsyl.f b/src/lib/lapack/dtgsyl.f
new file mode 100644
index 00000000..01866717
--- /dev/null
+++ b/src/lib/lapack/dtgsyl.f
@@ -0,0 +1,556 @@
+      SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
+     $                   LWORK, M, N
+      DOUBLE PRECISION   DIF, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTGSYL solves the generalized Sylvester equation:
+*
+*              A * R - L * B = scale * C                 (1)
+*              D * R - L * E = scale * F
+*
+*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and
+*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
+*  respectively, with real entries. (A, D) and (B, E) must be in
+*  generalized (real) Schur canonical form, i.e. A, B are upper quasi
+*  triangular and D, E are upper triangular.
+*
+*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
+*  scaling factor chosen to avoid overflow.
+*
+*  In matrix notation (1) is equivalent to solve  Zx = scale b, where
+*  Z is defined as
+*
+*             Z = [ kron(In, A)  -kron(B', Im) ]         (2)
+*                 [ kron(In, D)  -kron(E', Im) ].
+*
+*  Here Ik is the identity matrix of size k and X' is the transpose of
+*  X. kron(X, Y) is the Kronecker product between the matrices X and Y.
+*
+*  If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,
+*  which is equivalent to solve for R and L in
+*
+*              A' * R  + D' * L   = scale *  C           (3)
+*              R  * B' + L  * E'  = scale * (-F)
+*
+*  This case (TRANS = 'T') is used to compute an one-norm-based estimate
+*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
+*  and (B,E), using DLACON.
+*
+*  If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate
+*  of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
+*  reciprocal of the smallest singular value of Z. See [1-2] for more
+*  information.
+*
+*  This is a level 3 BLAS algorithm.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N', solve the generalized Sylvester equation (1).
+*          = 'T', solve the 'transposed' system (3).
+*
+*  IJOB    (input) INTEGER
+*          Specifies what kind of functionality to be performed.
+*           =0: solve (1) only.
+*           =1: The functionality of 0 and 3.
+*           =2: The functionality of 0 and 4.
+*           =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
+*               (look ahead strategy IJOB  = 1 is used).
+*           =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
+*               ( DGECON on sub-systems is used ).
+*          Not referenced if TRANS = 'T'.
+*
+*  M       (input) INTEGER
+*          The order of the matrices A and D, and the row dimension of
+*          the matrices C, F, R and L.
+*
+*  N       (input) INTEGER
+*          The order of the matrices B and E, and the column dimension
+*          of the matrices C, F, R and L.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)
+*          The upper quasi triangular matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1, M).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)
+*          The upper quasi triangular matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1, N).
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, N)
+*          On entry, C contains the right-hand-side of the first matrix
+*          equation in (1) or (3).
+*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
+*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
+*          the solution achieved during the computation of the
+*          Dif-estimate.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1, M).
+*
+*  D       (input) DOUBLE PRECISION array, dimension (LDD, M)
+*          The upper triangular matrix D.
+*
+*  LDD     (input) INTEGER
+*          The leading dimension of the array D. LDD >= max(1, M).
+*
+*  E       (input) DOUBLE PRECISION array, dimension (LDE, N)
+*          The upper triangular matrix E.
+*
+*  LDE     (input) INTEGER
+*          The leading dimension of the array E. LDE >= max(1, N).
+*
+*  F       (input/output) DOUBLE PRECISION array, dimension (LDF, N)
+*          On entry, F contains the right-hand-side of the second matrix
+*          equation in (1) or (3).
+*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
+*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
+*          the solution achieved during the computation of the
+*          Dif-estimate.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the array F. LDF >= max(1, M).
+*
+*  DIF     (output) DOUBLE PRECISION
+*          On exit DIF is the reciprocal of a lower bound of the
+*          reciprocal of the Dif-function, i.e. DIF is an upper bound of
+*          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
+*          IF IJOB = 0 or TRANS = 'T', DIF is not touched.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit SCALE is the scaling factor in (1) or (3).
+*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
+*          to a slightly perturbed system but the input matrices A, B, D
+*          and E have not been changed. If SCALE = 0, C and F hold the
+*          solutions R and L, respectively, to the homogeneous system
+*          with C = F = 0. Normally, SCALE = 1.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK > = 1.
+*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (M+N+6)
+*
+*  INFO    (output) INTEGER
+*            =0: successful exit
+*            <0: If INFO = -i, the i-th argument had an illegal value.
+*            >0: (A, D) and (B, E) have common or close eigenvalues.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+*      for Solving the Generalized Sylvester Equation and Estimating the
+*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
+*      No 1, 1996.
+*
+*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
+*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
+*      Appl., 15(4):1045-1060, 1994
+*
+*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
+*      Condition Estimators for Solving the Generalized Sylvester
+*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
+*      July 1989, pp 745-751.
+*
+*  =====================================================================
+*  Replaced various illegal calls to DCOPY by calls to DLASET.
+*  Sven Hammarling, 1/5/02.
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOTRAN
+      INTEGER            I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
+     $                   LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
+      DOUBLE PRECISION   DSCALE, DSUM, SCALE2, SCALOC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input parameters
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+         INFO = -1
+      ELSE IF( NOTRAN ) THEN
+         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
+            INFO = -2
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( M.LE.0 ) THEN
+            INFO = -3
+         ELSE IF( N.LE.0 ) THEN
+            INFO = -4
+         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+            INFO = -6
+         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+            INFO = -8
+         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+            INFO = -10
+         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+            INFO = -12
+         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+            INFO = -14
+         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( NOTRAN ) THEN
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
+               LWMIN = MAX( 1, 2*M*N )
+            ELSE
+               LWMIN = 1
+            END IF
+         ELSE
+            LWMIN = 1
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTGSYL', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         SCALE = 1
+         IF( NOTRAN ) THEN
+            IF( IJOB.NE.0 ) THEN
+               DIF = 0
+            END IF
+         END IF
+         RETURN
+      END IF
+*
+*     Determine optimal block sizes MB and NB
+*
+      MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 )
+      NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 )
+*
+      ISOLVE = 1
+      IFUNC = 0
+      IF( NOTRAN ) THEN
+         IF( IJOB.GE.3 ) THEN
+            IFUNC = IJOB - 2
+            CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+            CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+         ELSE IF( IJOB.GE.1 ) THEN
+            ISOLVE = 2
+         END IF
+      END IF
+*
+      IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
+     $     THEN
+*
+         DO 30 IROUND = 1, ISOLVE
+*
+*           Use unblocked Level 2 solver
+*
+            DSCALE = ZERO
+            DSUM = ONE
+            PQ = 0
+            CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
+     $                   IWORK, PQ, INFO )
+            IF( DSCALE.NE.ZERO ) THEN
+               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+               END IF
+            END IF
+*
+            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+               IF( NOTRAN ) THEN
+                  IFUNC = IJOB
+               END IF
+               SCALE2 = SCALE
+               CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+               CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+               SCALE = SCALE2
+            END IF
+   30    CONTINUE
+*
+         RETURN
+      END IF
+*
+*     Determine block structure of A
+*
+      P = 0
+      I = 1
+   40 CONTINUE
+      IF( I.GT.M )
+     $   GO TO 50
+      P = P + 1
+      IWORK( P ) = I
+      I = I + MB
+      IF( I.GE.M )
+     $   GO TO 50
+      IF( A( I, I-1 ).NE.ZERO )
+     $   I = I + 1
+      GO TO 40
+   50 CONTINUE
+*
+      IWORK( P+1 ) = M + 1
+      IF( IWORK( P ).EQ.IWORK( P+1 ) )
+     $   P = P - 1
+*
+*     Determine block structure of B
+*
+      Q = P + 1
+      J = 1
+   60 CONTINUE
+      IF( J.GT.N )
+     $   GO TO 70
+      Q = Q + 1
+      IWORK( Q ) = J
+      J = J + NB
+      IF( J.GE.N )
+     $   GO TO 70
+      IF( B( J, J-1 ).NE.ZERO )
+     $   J = J + 1
+      GO TO 60
+   70 CONTINUE
+*
+      IWORK( Q+1 ) = N + 1
+      IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
+     $   Q = Q - 1
+*
+      IF( NOTRAN ) THEN
+*
+         DO 150 IROUND = 1, ISOLVE
+*
+*           Solve (I, J)-subsystem
+*               A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+*               D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+*           for I = P, P - 1,..., 1; J = 1, 2,..., Q
+*
+            DSCALE = ZERO
+            DSUM = ONE
+            PQ = 0
+            SCALE = ONE
+            DO 130 J = P + 2, Q
+               JS = IWORK( J )
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               DO 120 I = P, 1, -1
+                  IS = IWORK( I )
+                  IE = IWORK( I+1 ) - 1
+                  MB = IE - IS + 1
+                  PPQQ = 0
+                  CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+     $                         B( JS, JS ), LDB, C( IS, JS ), LDC,
+     $                         D( IS, IS ), LDD, E( JS, JS ), LDE,
+     $                         F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+     $                         IWORK( Q+2 ), PPQQ, LINFO )
+                  IF( LINFO.GT.0 )
+     $               INFO = LINFO
+*
+                  PQ = PQ + PPQQ
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 80 K = 1, JS - 1
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+   80                CONTINUE
+                     DO 90 K = JS, JE
+                        CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+   90                CONTINUE
+                     DO 100 K = JS, JE
+                        CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+                        CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+  100                CONTINUE
+                     DO 110 K = JE + 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                        CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  110                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Substitute R(I, J) and L(I, J) into remaining
+*                 equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
+     $                           C( 1, JS ), LDC )
+                     CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+     $                           D( 1, IS ), LDD, C( IS, JS ), LDC, ONE,
+     $                           F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+     $                           F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
+     $                           ONE, C( IS, JE+1 ), LDC )
+                     CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+     $                           F( IS, JS ), LDF, E( JS, JE+1 ), LDE,
+     $                           ONE, F( IS, JE+1 ), LDF )
+                  END IF
+  120          CONTINUE
+  130       CONTINUE
+            IF( DSCALE.NE.ZERO ) THEN
+               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+               END IF
+            END IF
+            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+               IF( NOTRAN ) THEN
+                  IFUNC = IJOB
+               END IF
+               SCALE2 = SCALE
+               CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+               CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+               SCALE = SCALE2
+            END IF
+  150    CONTINUE
+*
+      ELSE
+*
+*        Solve transposed (I, J)-subsystem
+*             A(I, I)' * R(I, J)  + D(I, I)' * L(I, J)  =  C(I, J)
+*             R(I, J)  * B(J, J)' + L(I, J)  * E(J, J)' = -F(I, J)
+*        for I = 1,2,..., P; J = Q, Q-1,..., 1
+*
+         SCALE = ONE
+         DO 210 I = 1, P
+            IS = IWORK( I )
+            IE = IWORK( I+1 ) - 1
+            MB = IE - IS + 1
+            DO 200 J = Q, P + 2, -1
+               JS = IWORK( J )
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+     $                      B( JS, JS ), LDB, C( IS, JS ), LDC,
+     $                      D( IS, IS ), LDD, E( JS, JS ), LDE,
+     $                      F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+     $                      IWORK( Q+2 ), PPQQ, LINFO )
+               IF( LINFO.GT.0 )
+     $            INFO = LINFO
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 160 K = 1, JS - 1
+                     CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                     CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  160             CONTINUE
+                  DO 170 K = JS, JE
+                     CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+                     CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+  170             CONTINUE
+                  DO 180 K = JS, JE
+                     CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+                     CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+  180             CONTINUE
+                  DO 190 K = JE + 1, N
+                     CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+                     CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+  190             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+*
+*              Substitute R(I, J) and L(I, J) into remaining equation.
+*
+               IF( J.GT.P+2 ) THEN
+                  CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
+     $                        LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
+     $                        LDF )
+                  CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ),
+     $                        LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ),
+     $                        LDF )
+               END IF
+               IF( I.LT.P ) THEN
+                  CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                        A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
+     $                        C( IE+1, JS ), LDC )
+                  CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+     $                        D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE,
+     $                        C( IE+1, JS ), LDC )
+               END IF
+  200       CONTINUE
+  210    CONTINUE
+*
+      END IF
+*
+      WORK( 1 ) = LWMIN
+*
+      RETURN
+*
+*     End of DTGSYL
+*
+      END
diff --git a/src/lib/lapack/dtrcon.f b/src/lib/lapack/dtrcon.f
new file mode 100644
index 00000000..23da5927
--- /dev/null
+++ b/src/lib/lapack/dtrcon.f
@@ -0,0 +1,197 @@
+      SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORM, UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRCON estimates the reciprocal of the condition number of a
+*  triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+*  The norm of A is computed and an estimate is obtained for
+*  norm(inv(A)), then the reciprocal of the condition number is
+*  computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies whether the 1-norm condition number or the
+*          infinity-norm condition number is required:
+*          = '1' or 'O':  1-norm;
+*          = 'I':         Infinity-norm.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  DIAG    (input) CHARACTER*1
+*          = 'N':  A is non-unit triangular;
+*          = 'U':  A is unit triangular.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
+*          upper triangular part of the array A contains the upper
+*          triangular matrix, and the strictly lower triangular part of
+*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
+*          triangular part of the array A contains the lower triangular
+*          matrix, and the strictly upper triangular part of A is not
+*          referenced.  If DIAG = 'U', the diagonal elements of A are
+*          also not referenced and are assumed to be 1.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  IWORK   (workspace) INTEGER array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, ONENRM, UPPER
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      DOUBLE PRECISION   AINVNM, ANORM, SCALE, SMLNUM, XNORM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DLANTR
+      EXTERNAL           LSAME, IDAMAX, DLAMCH, DLANTR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLATRS, DRSCL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRCON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      END IF
+*
+      RCOND = ZERO
+      SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+*     Compute the norm of the triangular matrix A.
+*
+      ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
+*
+*     Continue only if ANORM > 0.
+*
+      IF( ANORM.GT.ZERO ) THEN
+*
+*        Estimate the norm of the inverse of A.
+*
+         AINVNM = ZERO
+         NORMIN = 'N'
+         IF( ONENRM ) THEN
+            KASE1 = 1
+         ELSE
+            KASE1 = 2
+         END IF
+         KASE = 0
+   10    CONTINUE
+         CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.KASE1 ) THEN
+*
+*              Multiply by inv(A).
+*
+               CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+     $                      LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
+            ELSE
+*
+*              Multiply by inv(A').
+*
+               CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
+     $                      WORK, SCALE, WORK( 2*N+1 ), INFO )
+            END IF
+            NORMIN = 'Y'
+*
+*           Multiply by 1/SCALE if doing so will not cause overflow.
+*
+            IF( SCALE.NE.ONE ) THEN
+               IX = IDAMAX( N, WORK, 1 )
+               XNORM = ABS( WORK( IX ) )
+               IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+     $            GO TO 20
+               CALL DRSCL( N, SCALE, WORK, 1 )
+            END IF
+            GO TO 10
+         END IF
+*
+*        Compute the estimate of the reciprocal condition number.
+*
+         IF( AINVNM.NE.ZERO )
+     $      RCOND = ( ONE / ANORM ) / AINVNM
+      END IF
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of DTRCON
+*
+      END
diff --git a/src/lib/lapack/dtrevc.f b/src/lib/lapack/dtrevc.f
new file mode 100644
index 00000000..a0215f02
--- /dev/null
+++ b/src/lib/lapack/dtrevc.f
@@ -0,0 +1,980 @@
+      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, MM, M, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, SIDE
+      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      DOUBLE PRECISION   T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTREVC computes some or all of the right and/or left eigenvectors of
+*  a real upper quasi-triangular matrix T.
+*  Matrices of this type are produced by the Schur factorization of
+*  a real general matrix:  A = Q*T*Q**T, as computed by DHSEQR.
+*  
+*  The right eigenvector x and the left eigenvector y of T corresponding
+*  to an eigenvalue w are defined by:
+*  
+*     T*x = w*x,     (y**H)*T = w*(y**H)
+*  
+*  where y**H denotes the conjugate transpose of y.
+*  The eigenvalues are not input to this routine, but are read directly
+*  from the diagonal blocks of T.
+*  
+*  This routine returns the matrices X and/or Y of right and left
+*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+*  input matrix.  If Q is the orthogonal factor that reduces a matrix
+*  A to Schur form T, then Q*X and Q*Y are the matrices of right and
+*  left eigenvectors of A.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  compute right eigenvectors only;
+*          = 'L':  compute left eigenvectors only;
+*          = 'B':  compute both right and left eigenvectors.
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A':  compute all right and/or left eigenvectors;
+*          = 'B':  compute all right and/or left eigenvectors,
+*                  backtransformed by the matrices in VR and/or VL;
+*          = 'S':  compute selected right and/or left eigenvectors,
+*                  as indicated by the logical array SELECT.
+*
+*  SELECT  (input/output) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+*          computed.
+*          If w(j) is a real eigenvalue, the corresponding real
+*          eigenvector is computed if SELECT(j) is .TRUE..
+*          If w(j) and w(j+1) are the real and imaginary parts of a
+*          complex eigenvalue, the corresponding complex eigenvector is
+*          computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
+*          on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
+*          .FALSE..
+*          Not referenced if HOWMNY = 'A' or 'B'.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)
+*          The upper quasi-triangular matrix T in Schur canonical form.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*          contain an N-by-N matrix Q (usually the orthogonal matrix Q
+*          of Schur vectors returned by DHSEQR).
+*          On exit, if SIDE = 'L' or 'B', VL contains:
+*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+*          if HOWMNY = 'B', the matrix Q*Y;
+*          if HOWMNY = 'S', the left eigenvectors of T specified by
+*                           SELECT, stored consecutively in the columns
+*                           of VL, in the same order as their
+*                           eigenvalues.
+*          A complex eigenvector corresponding to a complex eigenvalue
+*          is stored in two consecutive columns, the first holding the
+*          real part, and the second the imaginary part.
+*          Not referenced if SIDE = 'R'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.  LDVL >= 1, and if
+*          SIDE = 'L' or 'B', LDVL >= N.
+*
+*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*          contain an N-by-N matrix Q (usually the orthogonal matrix Q
+*          of Schur vectors returned by DHSEQR).
+*          On exit, if SIDE = 'R' or 'B', VR contains:
+*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+*          if HOWMNY = 'B', the matrix Q*X;
+*          if HOWMNY = 'S', the right eigenvectors of T specified by
+*                           SELECT, stored consecutively in the columns
+*                           of VR, in the same order as their
+*                           eigenvalues.
+*          A complex eigenvector corresponding to a complex eigenvalue
+*          is stored in two consecutive columns, the first holding the
+*          real part and the second the imaginary part.
+*          Not referenced if SIDE = 'L'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1, and if
+*          SIDE = 'R' or 'B', LDVR >= N.
+*
+*  MM      (input) INTEGER
+*          The number of columns in the arrays VL and/or VR. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of columns in the arrays VL and/or VR actually
+*          used to store the eigenvectors.
+*          If HOWMNY = 'A' or 'B', M is set to N.
+*          Each selected real eigenvector occupies one column and each
+*          selected complex eigenvector occupies two columns.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The algorithm used in this program is basically backward (forward)
+*  substitution, with scaling to make the the code robust against
+*  possible overflow.
+*
+*  Each eigenvector is normalized so that the element of largest
+*  magnitude has magnitude 1; here the magnitude of a complex number
+*  (x,y) is taken to be |x| + |y|.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
+      INTEGER            I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
+      DOUBLE PRECISION   BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
+     $                   SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
+     $                   XNORM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DDOT, DLAMCH
+      EXTERNAL           LSAME, IDAMAX, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   X( 2, 2 )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      BOTHV = LSAME( SIDE, 'B' )
+      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+      ALLV = LSAME( HOWMNY, 'A' )
+      OVER = LSAME( HOWMNY, 'B' )
+      SOMEV = LSAME( HOWMNY, 'S' )
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE
+*
+*        Set M to the number of columns required to store the selected
+*        eigenvectors, standardize the array SELECT if necessary, and
+*        test MM.
+*
+         IF( SOMEV ) THEN
+            M = 0
+            PAIR = .FALSE.
+            DO 10 J = 1, N
+               IF( PAIR ) THEN
+                  PAIR = .FALSE.
+                  SELECT( J ) = .FALSE.
+               ELSE
+                  IF( J.LT.N ) THEN
+                     IF( T( J+1, J ).EQ.ZERO ) THEN
+                        IF( SELECT( J ) )
+     $                     M = M + 1
+                     ELSE
+                        PAIR = .TRUE.
+                        IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
+                           SELECT( J ) = .TRUE.
+                           M = M + 2
+                        END IF
+                     END IF
+                  ELSE
+                     IF( SELECT( N ) )
+     $                  M = M + 1
+                  END IF
+               END IF
+   10       CONTINUE
+         ELSE
+            M = N
+         END IF
+*
+         IF( MM.LT.M ) THEN
+            INFO = -11
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTREVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set the constants to control overflow.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+      BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+*     Compute 1-norm of each column of strictly upper triangular
+*     part of T to control overflow in triangular solver.
+*
+      WORK( 1 ) = ZERO
+      DO 30 J = 2, N
+         WORK( J ) = ZERO
+         DO 20 I = 1, J - 1
+            WORK( J ) = WORK( J ) + ABS( T( I, J ) )
+   20    CONTINUE
+   30 CONTINUE
+*
+*     Index IP is used to specify the real or complex eigenvalue:
+*       IP = 0, real eigenvalue,
+*            1, first of conjugate complex pair: (wr,wi)
+*           -1, second of conjugate complex pair: (wr,wi)
+*
+      N2 = 2*N
+*
+      IF( RIGHTV ) THEN
+*
+*        Compute right eigenvectors.
+*
+         IP = 0
+         IS = M
+         DO 140 KI = N, 1, -1
+*
+            IF( IP.EQ.1 )
+     $         GO TO 130
+            IF( KI.EQ.1 )
+     $         GO TO 40
+            IF( T( KI, KI-1 ).EQ.ZERO )
+     $         GO TO 40
+            IP = -1
+*
+   40       CONTINUE
+            IF( SOMEV ) THEN
+               IF( IP.EQ.0 ) THEN
+                  IF( .NOT.SELECT( KI ) )
+     $               GO TO 130
+               ELSE
+                  IF( .NOT.SELECT( KI-1 ) )
+     $               GO TO 130
+               END IF
+            END IF
+*
+*           Compute the KI-th eigenvalue (WR,WI).
+*
+            WR = T( KI, KI )
+            WI = ZERO
+            IF( IP.NE.0 )
+     $         WI = SQRT( ABS( T( KI, KI-1 ) ) )*
+     $              SQRT( ABS( T( KI-1, KI ) ) )
+            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+            IF( IP.EQ.0 ) THEN
+*
+*              Real right eigenvector
+*
+               WORK( KI+N ) = ONE
+*
+*              Form right-hand side
+*
+               DO 50 K = 1, KI - 1
+                  WORK( K+N ) = -T( K, KI )
+   50          CONTINUE
+*
+*              Solve the upper quasi-triangular system:
+*                 (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
+*
+               JNXT = KI - 1
+               DO 60 J = KI - 1, 1, -1
+                  IF( J.GT.JNXT )
+     $               GO TO 60
+                  J1 = J
+                  J2 = J
+                  JNXT = J - 1
+                  IF( J.GT.1 ) THEN
+                     IF( T( J, J-1 ).NE.ZERO ) THEN
+                        J1 = J - 1
+                        JNXT = J - 2
+                     END IF
+                  END IF
+*
+                  IF( J1.EQ.J2 ) THEN
+*
+*                    1-by-1 diagonal block
+*
+                     CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
+     $                            ZERO, X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale X(1,1) to avoid overflow when updating
+*                    the right-hand side.
+*
+                     IF( XNORM.GT.ONE ) THEN
+                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+                           X( 1, 1 ) = X( 1, 1 ) / XNORM
+                           SCALE = SCALE / XNORM
+                        END IF
+                     END IF
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE )
+     $                  CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                     WORK( J+N ) = X( 1, 1 )
+*
+*                    Update right-hand side
+*
+                     CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+                     CALL DLALN2( .FALSE., 2, 1, SMIN, ONE,
+     $                            T( J-1, J-1 ), LDT, ONE, ONE,
+     $                            WORK( J-1+N ), N, WR, ZERO, X, 2,
+     $                            SCALE, XNORM, IERR )
+*
+*                    Scale X(1,1) and X(2,1) to avoid overflow when
+*                    updating the right-hand side.
+*
+                     IF( XNORM.GT.ONE ) THEN
+                        BETA = MAX( WORK( J-1 ), WORK( J ) )
+                        IF( BETA.GT.BIGNUM / XNORM ) THEN
+                           X( 1, 1 ) = X( 1, 1 ) / XNORM
+                           X( 2, 1 ) = X( 2, 1 ) / XNORM
+                           SCALE = SCALE / XNORM
+                        END IF
+                     END IF
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE )
+     $                  CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                     WORK( J-1+N ) = X( 1, 1 )
+                     WORK( J+N ) = X( 2, 1 )
+*
+*                    Update right-hand side
+*
+                     CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+                  END IF
+   60          CONTINUE
+*
+*              Copy the vector x or Q*x to VR and normalize.
+*
+               IF( .NOT.OVER ) THEN
+                  CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
+*
+                  II = IDAMAX( KI, VR( 1, IS ), 1 )
+                  REMAX = ONE / ABS( VR( II, IS ) )
+                  CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+                  DO 70 K = KI + 1, N
+                     VR( K, IS ) = ZERO
+   70             CONTINUE
+               ELSE
+                  IF( KI.GT.1 )
+     $               CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR,
+     $                           WORK( 1+N ), 1, WORK( KI+N ),
+     $                           VR( 1, KI ), 1 )
+*
+                  II = IDAMAX( N, VR( 1, KI ), 1 )
+                  REMAX = ONE / ABS( VR( II, KI ) )
+                  CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
+               END IF
+*
+            ELSE
+*
+*              Complex right eigenvector.
+*
+*              Initial solve
+*                [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
+*                [ (T(KI,KI-1)   T(KI,KI)   )               ]
+*
+               IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
+                  WORK( KI-1+N ) = ONE
+                  WORK( KI+N2 ) = WI / T( KI-1, KI )
+               ELSE
+                  WORK( KI-1+N ) = -WI / T( KI, KI-1 )
+                  WORK( KI+N2 ) = ONE
+               END IF
+               WORK( KI+N ) = ZERO
+               WORK( KI-1+N2 ) = ZERO
+*
+*              Form right-hand side
+*
+               DO 80 K = 1, KI - 2
+                  WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
+                  WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
+   80          CONTINUE
+*
+*              Solve upper quasi-triangular system:
+*              (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
+*
+               JNXT = KI - 2
+               DO 90 J = KI - 2, 1, -1
+                  IF( J.GT.JNXT )
+     $               GO TO 90
+                  J1 = J
+                  J2 = J
+                  JNXT = J - 1
+                  IF( J.GT.1 ) THEN
+                     IF( T( J, J-1 ).NE.ZERO ) THEN
+                        J1 = J - 1
+                        JNXT = J - 2
+                     END IF
+                  END IF
+*
+                  IF( J1.EQ.J2 ) THEN
+*
+*                    1-by-1 diagonal block
+*
+                     CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
+     $                            X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale X(1,1) and X(1,2) to avoid overflow when
+*                    updating the right-hand side.
+*
+                     IF( XNORM.GT.ONE ) THEN
+                        IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+                           X( 1, 1 ) = X( 1, 1 ) / XNORM
+                           X( 1, 2 ) = X( 1, 2 ) / XNORM
+                           SCALE = SCALE / XNORM
+                        END IF
+                     END IF
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE ) THEN
+                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                        CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+                     END IF
+                     WORK( J+N ) = X( 1, 1 )
+                     WORK( J+N2 ) = X( 1, 2 )
+*
+*                    Update the right-hand side
+*
+                     CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
+     $                           WORK( 1+N2 ), 1 )
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+                     CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
+     $                            T( J-1, J-1 ), LDT, ONE, ONE,
+     $                            WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
+     $                            XNORM, IERR )
+*
+*                    Scale X to avoid overflow when updating
+*                    the right-hand side.
+*
+                     IF( XNORM.GT.ONE ) THEN
+                        BETA = MAX( WORK( J-1 ), WORK( J ) )
+                        IF( BETA.GT.BIGNUM / XNORM ) THEN
+                           REC = ONE / XNORM
+                           X( 1, 1 ) = X( 1, 1 )*REC
+                           X( 1, 2 ) = X( 1, 2 )*REC
+                           X( 2, 1 ) = X( 2, 1 )*REC
+                           X( 2, 2 ) = X( 2, 2 )*REC
+                           SCALE = SCALE*REC
+                        END IF
+                     END IF
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE ) THEN
+                        CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+                        CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+                     END IF
+                     WORK( J-1+N ) = X( 1, 1 )
+                     WORK( J+N ) = X( 2, 1 )
+                     WORK( J-1+N2 ) = X( 1, 2 )
+                     WORK( J+N2 ) = X( 2, 2 )
+*
+*                    Update the right-hand side
+*
+                     CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+     $                           WORK( 1+N ), 1 )
+                     CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
+     $                           WORK( 1+N2 ), 1 )
+                     CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
+     $                           WORK( 1+N2 ), 1 )
+                  END IF
+   90          CONTINUE
+*
+*              Copy the vector x or Q*x to VR and normalize.
+*
+               IF( .NOT.OVER ) THEN
+                  CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
+                  CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
+*
+                  EMAX = ZERO
+                  DO 100 K = 1, KI
+                     EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
+     $                      ABS( VR( K, IS ) ) )
+  100             CONTINUE
+*
+                  REMAX = ONE / EMAX
+                  CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
+                  CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+                  DO 110 K = KI + 1, N
+                     VR( K, IS-1 ) = ZERO
+                     VR( K, IS ) = ZERO
+  110             CONTINUE
+*
+               ELSE
+*
+                  IF( KI.GT.2 ) THEN
+                     CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+     $                           WORK( 1+N ), 1, WORK( KI-1+N ),
+     $                           VR( 1, KI-1 ), 1 )
+                     CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+     $                           WORK( 1+N2 ), 1, WORK( KI+N2 ),
+     $                           VR( 1, KI ), 1 )
+                  ELSE
+                     CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
+                     CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
+                  END IF
+*
+                  EMAX = ZERO
+                  DO 120 K = 1, N
+                     EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
+     $                      ABS( VR( K, KI ) ) )
+  120             CONTINUE
+                  REMAX = ONE / EMAX
+                  CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
+                  CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
+               END IF
+            END IF
+*
+            IS = IS - 1
+            IF( IP.NE.0 )
+     $         IS = IS - 1
+  130       CONTINUE
+            IF( IP.EQ.1 )
+     $         IP = 0
+            IF( IP.EQ.-1 )
+     $         IP = 1
+  140    CONTINUE
+      END IF
+*
+      IF( LEFTV ) THEN
+*
+*        Compute left eigenvectors.
+*
+         IP = 0
+         IS = 1
+         DO 260 KI = 1, N
+*
+            IF( IP.EQ.-1 )
+     $         GO TO 250
+            IF( KI.EQ.N )
+     $         GO TO 150
+            IF( T( KI+1, KI ).EQ.ZERO )
+     $         GO TO 150
+            IP = 1
+*
+  150       CONTINUE
+            IF( SOMEV ) THEN
+               IF( .NOT.SELECT( KI ) )
+     $            GO TO 250
+            END IF
+*
+*           Compute the KI-th eigenvalue (WR,WI).
+*
+            WR = T( KI, KI )
+            WI = ZERO
+            IF( IP.NE.0 )
+     $         WI = SQRT( ABS( T( KI, KI+1 ) ) )*
+     $              SQRT( ABS( T( KI+1, KI ) ) )
+            SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+            IF( IP.EQ.0 ) THEN
+*
+*              Real left eigenvector.
+*
+               WORK( KI+N ) = ONE
+*
+*              Form right-hand side
+*
+               DO 160 K = KI + 1, N
+                  WORK( K+N ) = -T( KI, K )
+  160          CONTINUE
+*
+*              Solve the quasi-triangular system:
+*                 (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
+*
+               VMAX = ONE
+               VCRIT = BIGNUM
+*
+               JNXT = KI + 1
+               DO 170 J = KI + 1, N
+                  IF( J.LT.JNXT )
+     $               GO TO 170
+                  J1 = J
+                  J2 = J
+                  JNXT = J + 1
+                  IF( J.LT.N ) THEN
+                     IF( T( J+1, J ).NE.ZERO ) THEN
+                        J2 = J + 1
+                        JNXT = J + 2
+                     END IF
+                  END IF
+*
+                  IF( J1.EQ.J2 ) THEN
+*
+*                    1-by-1 diagonal block
+*
+*                    Scale if necessary to avoid overflow when forming
+*                    the right-hand side.
+*
+                     IF( WORK( J ).GT.VCRIT ) THEN
+                        REC = ONE / VMAX
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             DDOT( J-KI-1, T( KI+1, J ), 1,
+     $                             WORK( KI+1+N ), 1 )
+*
+*                    Solve (T(J,J)-WR)'*X = WORK
+*
+                     CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
+     $                            ZERO, X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE )
+     $                  CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                     WORK( J+N ) = X( 1, 1 )
+                     VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
+                     VCRIT = BIGNUM / VMAX
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+*                    Scale if necessary to avoid overflow when forming
+*                    the right-hand side.
+*
+                     BETA = MAX( WORK( J ), WORK( J+1 ) )
+                     IF( BETA.GT.VCRIT ) THEN
+                        REC = ONE / VMAX
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             DDOT( J-KI-1, T( KI+1, J ), 1,
+     $                             WORK( KI+1+N ), 1 )
+*
+                     WORK( J+1+N ) = WORK( J+1+N ) -
+     $                               DDOT( J-KI-1, T( KI+1, J+1 ), 1,
+     $                               WORK( KI+1+N ), 1 )
+*
+*                    Solve
+*                      [T(J,J)-WR   T(J,J+1)     ]'* X = SCALE*( WORK1 )
+*                      [T(J+1,J)    T(J+1,J+1)-WR]             ( WORK2 )
+*
+                     CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
+     $                            ZERO, X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE )
+     $                  CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                     WORK( J+N ) = X( 1, 1 )
+                     WORK( J+1+N ) = X( 2, 1 )
+*
+                     VMAX = MAX( ABS( WORK( J+N ) ),
+     $                      ABS( WORK( J+1+N ) ), VMAX )
+                     VCRIT = BIGNUM / VMAX
+*
+                  END IF
+  170          CONTINUE
+*
+*              Copy the vector x or Q*x to VL and normalize.
+*
+               IF( .NOT.OVER ) THEN
+                  CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+*
+                  II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+                  REMAX = ONE / ABS( VL( II, IS ) )
+                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+*
+                  DO 180 K = 1, KI - 1
+                     VL( K, IS ) = ZERO
+  180             CONTINUE
+*
+               ELSE
+*
+                  IF( KI.LT.N )
+     $               CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
+     $                           WORK( KI+1+N ), 1, WORK( KI+N ),
+     $                           VL( 1, KI ), 1 )
+*
+                  II = IDAMAX( N, VL( 1, KI ), 1 )
+                  REMAX = ONE / ABS( VL( II, KI ) )
+                  CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
+*
+               END IF
+*
+            ELSE
+*
+*              Complex left eigenvector.
+*
+*               Initial solve:
+*                 ((T(KI,KI)    T(KI,KI+1) )' - (WR - I* WI))*X = 0.
+*                 ((T(KI+1,KI) T(KI+1,KI+1))                )
+*
+               IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
+                  WORK( KI+N ) = WI / T( KI, KI+1 )
+                  WORK( KI+1+N2 ) = ONE
+               ELSE
+                  WORK( KI+N ) = ONE
+                  WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
+               END IF
+               WORK( KI+1+N ) = ZERO
+               WORK( KI+N2 ) = ZERO
+*
+*              Form right-hand side
+*
+               DO 190 K = KI + 2, N
+                  WORK( K+N ) = -WORK( KI+N )*T( KI, K )
+                  WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
+  190          CONTINUE
+*
+*              Solve complex quasi-triangular system:
+*              ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
+*
+               VMAX = ONE
+               VCRIT = BIGNUM
+*
+               JNXT = KI + 2
+               DO 200 J = KI + 2, N
+                  IF( J.LT.JNXT )
+     $               GO TO 200
+                  J1 = J
+                  J2 = J
+                  JNXT = J + 1
+                  IF( J.LT.N ) THEN
+                     IF( T( J+1, J ).NE.ZERO ) THEN
+                        J2 = J + 1
+                        JNXT = J + 2
+                     END IF
+                  END IF
+*
+                  IF( J1.EQ.J2 ) THEN
+*
+*                    1-by-1 diagonal block
+*
+*                    Scale if necessary to avoid overflow when
+*                    forming the right-hand side elements.
+*
+                     IF( WORK( J ).GT.VCRIT ) THEN
+                        REC = ONE / VMAX
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             DDOT( J-KI-2, T( KI+2, J ), 1,
+     $                             WORK( KI+2+N ), 1 )
+                     WORK( J+N2 ) = WORK( J+N2 ) -
+     $                              DDOT( J-KI-2, T( KI+2, J ), 1,
+     $                              WORK( KI+2+N2 ), 1 )
+*
+*                    Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
+*
+                     CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
+     $                            -WI, X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE ) THEN
+                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+                     END IF
+                     WORK( J+N ) = X( 1, 1 )
+                     WORK( J+N2 ) = X( 1, 2 )
+                     VMAX = MAX( ABS( WORK( J+N ) ),
+     $                      ABS( WORK( J+N2 ) ), VMAX )
+                     VCRIT = BIGNUM / VMAX
+*
+                  ELSE
+*
+*                    2-by-2 diagonal block
+*
+*                    Scale if necessary to avoid overflow when forming
+*                    the right-hand side elements.
+*
+                     BETA = MAX( WORK( J ), WORK( J+1 ) )
+                     IF( BETA.GT.VCRIT ) THEN
+                        REC = ONE / VMAX
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+                        CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+                        VMAX = ONE
+                        VCRIT = BIGNUM
+                     END IF
+*
+                     WORK( J+N ) = WORK( J+N ) -
+     $                             DDOT( J-KI-2, T( KI+2, J ), 1,
+     $                             WORK( KI+2+N ), 1 )
+*
+                     WORK( J+N2 ) = WORK( J+N2 ) -
+     $                              DDOT( J-KI-2, T( KI+2, J ), 1,
+     $                              WORK( KI+2+N2 ), 1 )
+*
+                     WORK( J+1+N ) = WORK( J+1+N ) -
+     $                               DDOT( J-KI-2, T( KI+2, J+1 ), 1,
+     $                               WORK( KI+2+N ), 1 )
+*
+                     WORK( J+1+N2 ) = WORK( J+1+N2 ) -
+     $                                DDOT( J-KI-2, T( KI+2, J+1 ), 1,
+     $                                WORK( KI+2+N2 ), 1 )
+*
+*                    Solve 2-by-2 complex linear equation
+*                      ([T(j,j)   T(j,j+1)  ]'-(wr-i*wi)*I)*X = SCALE*B
+*                      ([T(j+1,j) T(j+1,j+1)]             )
+*
+                     CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
+     $                            LDT, ONE, ONE, WORK( J+N ), N, WR,
+     $                            -WI, X, 2, SCALE, XNORM, IERR )
+*
+*                    Scale if necessary
+*
+                     IF( SCALE.NE.ONE ) THEN
+                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+                        CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+                     END IF
+                     WORK( J+N ) = X( 1, 1 )
+                     WORK( J+N2 ) = X( 1, 2 )
+                     WORK( J+1+N ) = X( 2, 1 )
+                     WORK( J+1+N2 ) = X( 2, 2 )
+                     VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
+     $                      ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
+                     VCRIT = BIGNUM / VMAX
+*
+                  END IF
+  200          CONTINUE
+*
+*              Copy the vector x or Q*x to VL and normalize.
+*
+               IF( .NOT.OVER ) THEN
+                  CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+                  CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
+     $                        1 )
+*
+                  EMAX = ZERO
+                  DO 220 K = KI, N
+                     EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
+     $                      ABS( VL( K, IS+1 ) ) )
+  220             CONTINUE
+                  REMAX = ONE / EMAX
+                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+                  CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
+*
+                  DO 230 K = 1, KI - 1
+                     VL( K, IS ) = ZERO
+                     VL( K, IS+1 ) = ZERO
+  230             CONTINUE
+               ELSE
+                  IF( KI.LT.N-1 ) THEN
+                     CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+     $                           LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
+     $                           VL( 1, KI ), 1 )
+                     CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+     $                           LDVL, WORK( KI+2+N2 ), 1,
+     $                           WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+                  ELSE
+                     CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
+                     CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+                  END IF
+*
+                  EMAX = ZERO
+                  DO 240 K = 1, N
+                     EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
+     $                      ABS( VL( K, KI+1 ) ) )
+  240             CONTINUE
+                  REMAX = ONE / EMAX
+                  CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
+                  CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
+*
+               END IF
+*
+            END IF
+*
+            IS = IS + 1
+            IF( IP.NE.0 )
+     $         IS = IS + 1
+  250       CONTINUE
+            IF( IP.EQ.-1 )
+     $         IP = 0
+            IF( IP.EQ.1 )
+     $         IP = -1
+*
+  260    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of DTREVC
+*
+      END
diff --git a/src/lib/lapack/dtrexc.f b/src/lib/lapack/dtrexc.f
new file mode 100644
index 00000000..db9be753
--- /dev/null
+++ b/src/lib/lapack/dtrexc.f
@@ -0,0 +1,345 @@
+      SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ
+      INTEGER            IFST, ILST, INFO, LDQ, LDT, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTREXC reorders the real Schur factorization of a real matrix
+*  A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
+*  moved to row ILST.
+*
+*  The real Schur form T is reordered by an orthogonal similarity
+*  transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
+*  is updated by postmultiplying it with Z.
+*
+*  T must be in Schur canonical form (as returned by DHSEQR), that is,
+*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+*  2-by-2 diagonal block has its diagonal elements equal and its
+*  off-diagonal elements of opposite sign.
+*
+*  Arguments
+*  =========
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'V':  update the matrix Q of Schur vectors;
+*          = 'N':  do not update Q.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+*          On entry, the upper quasi-triangular matrix T, in Schur
+*          Schur canonical form.
+*          On exit, the reordered upper quasi-triangular matrix, again
+*          in Schur canonical form.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+*          On exit, if COMPQ = 'V', Q has been postmultiplied by the
+*          orthogonal transformation matrix Z which reorders T.
+*          If COMPQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  IFST    (input/output) INTEGER
+*  ILST    (input/output) INTEGER
+*          Specify the reordering of the diagonal blocks of T.
+*          The block with row index IFST is moved to row ILST, by a
+*          sequence of transpositions between adjacent blocks.
+*          On exit, if IFST pointed on entry to the second row of a
+*          2-by-2 block, it is changed to point to the first row; ILST
+*          always points to the first row of the block in its final
+*          position (which may differ from its input value by +1 or -1).
+*          1 <= IFST <= N; 1 <= ILST <= N.
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          = 1:  two adjacent blocks were too close to swap (the problem
+*                is very ill-conditioned); T may have been partially
+*                reordered, and ILST points to the first row of the
+*                current position of the block being moved.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            WANTQ
+      INTEGER            HERE, NBF, NBL, NBNEXT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAEXC, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input arguments.
+*
+      INFO = 0
+      WANTQ = LSAME( COMPQ, 'V' )
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+         INFO = -7
+      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTREXC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Determine the first row of specified block
+*     and find out it is 1 by 1 or 2 by 2.
+*
+      IF( IFST.GT.1 ) THEN
+         IF( T( IFST, IFST-1 ).NE.ZERO )
+     $      IFST = IFST - 1
+      END IF
+      NBF = 1
+      IF( IFST.LT.N ) THEN
+         IF( T( IFST+1, IFST ).NE.ZERO )
+     $      NBF = 2
+      END IF
+*
+*     Determine the first row of the final block
+*     and find out it is 1 by 1 or 2 by 2.
+*
+      IF( ILST.GT.1 ) THEN
+         IF( T( ILST, ILST-1 ).NE.ZERO )
+     $      ILST = ILST - 1
+      END IF
+      NBL = 1
+      IF( ILST.LT.N ) THEN
+         IF( T( ILST+1, ILST ).NE.ZERO )
+     $      NBL = 2
+      END IF
+*
+      IF( IFST.EQ.ILST )
+     $   RETURN
+*
+      IF( IFST.LT.ILST ) THEN
+*
+*        Update ILST
+*
+         IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+     $      ILST = ILST - 1
+         IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+     $      ILST = ILST + 1
+*
+         HERE = IFST
+*
+   10    CONTINUE
+*
+*        Swap block with next one below
+*
+         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+*           Current block either 1 by 1 or 2 by 2
+*
+            NBNEXT = 1
+            IF( HERE+NBF+1.LE.N ) THEN
+               IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT,
+     $                   WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            HERE = HERE + NBNEXT
+*
+*           Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+            IF( NBF.EQ.2 ) THEN
+               IF( T( HERE+1, HERE ).EQ.ZERO )
+     $            NBF = 3
+            END IF
+*
+         ELSE
+*
+*           Current block consists of two 1 by 1 blocks each of which
+*           must be swapped individually
+*
+            NBNEXT = 1
+            IF( HERE+3.LE.N ) THEN
+               IF( T( HERE+3, HERE+2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT,
+     $                   WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            IF( NBNEXT.EQ.1 ) THEN
+*
+*              Swap two 1 by 1 blocks, no problems possible
+*
+               CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT,
+     $                      WORK, INFO )
+               HERE = HERE + 1
+            ELSE
+*
+*              Recompute NBNEXT in case 2 by 2 split
+*
+               IF( T( HERE+2, HERE+1 ).EQ.ZERO )
+     $            NBNEXT = 1
+               IF( NBNEXT.EQ.2 ) THEN
+*
+*                 2 by 2 Block did not split
+*
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1,
+     $                         NBNEXT, WORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE + 2
+               ELSE
+*
+*                 2 by 2 Block did split
+*
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+     $                         WORK, INFO )
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1,
+     $                         WORK, INFO )
+                  HERE = HERE + 2
+               END IF
+            END IF
+         END IF
+         IF( HERE.LT.ILST )
+     $      GO TO 10
+*
+      ELSE
+*
+         HERE = IFST
+   20    CONTINUE
+*
+*        Swap block with next one above
+*
+         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+*           Current block either 1 by 1 or 2 by 2
+*
+            NBNEXT = 1
+            IF( HERE.GE.3 ) THEN
+               IF( T( HERE-1, HERE-2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+     $                   NBF, WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            HERE = HERE - NBNEXT
+*
+*           Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+            IF( NBF.EQ.2 ) THEN
+               IF( T( HERE+1, HERE ).EQ.ZERO )
+     $            NBF = 3
+            END IF
+*
+         ELSE
+*
+*           Current block consists of two 1 by 1 blocks each of which
+*           must be swapped individually
+*
+            NBNEXT = 1
+            IF( HERE.GE.3 ) THEN
+               IF( T( HERE-1, HERE-2 ).NE.ZERO )
+     $            NBNEXT = 2
+            END IF
+            CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+     $                   1, WORK, INFO )
+            IF( INFO.NE.0 ) THEN
+               ILST = HERE
+               RETURN
+            END IF
+            IF( NBNEXT.EQ.1 ) THEN
+*
+*              Swap two 1 by 1 blocks, no problems possible
+*
+               CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1,
+     $                      WORK, INFO )
+               HERE = HERE - 1
+            ELSE
+*
+*              Recompute NBNEXT in case 2 by 2 split
+*
+               IF( T( HERE, HERE-1 ).EQ.ZERO )
+     $            NBNEXT = 1
+               IF( NBNEXT.EQ.2 ) THEN
+*
+*                 2 by 2 Block did not split
+*
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1,
+     $                         WORK, INFO )
+                  IF( INFO.NE.0 ) THEN
+                     ILST = HERE
+                     RETURN
+                  END IF
+                  HERE = HERE - 2
+               ELSE
+*
+*                 2 by 2 Block did split
+*
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+     $                         WORK, INFO )
+                  CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1,
+     $                         WORK, INFO )
+                  HERE = HERE - 2
+               END IF
+            END IF
+         END IF
+         IF( HERE.GT.ILST )
+     $      GO TO 20
+      END IF
+      ILST = HERE
+*
+      RETURN
+*
+*     End of DTREXC
+*
+      END
diff --git a/src/lib/lapack/dtrsen.f b/src/lib/lapack/dtrsen.f
new file mode 100644
index 00000000..1d3ab03a
--- /dev/null
+++ b/src/lib/lapack/dtrsen.f
@@ -0,0 +1,459 @@
+      SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
+     $                   M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, JOB
+      INTEGER            INFO, LDQ, LDT, LIWORK, LWORK, M, N
+      DOUBLE PRECISION   S, SEP
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
+     $                   WR( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRSEN reorders the real Schur factorization of a real matrix
+*  A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
+*  the leading diagonal blocks of the upper quasi-triangular matrix T,
+*  and the leading columns of Q form an orthonormal basis of the
+*  corresponding right invariant subspace.
+*
+*  Optionally the routine computes the reciprocal condition numbers of
+*  the cluster of eigenvalues and/or the invariant subspace.
+*
+*  T must be in Schur canonical form (as returned by DHSEQR), that is,
+*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+*  2-by-2 diagonal block has its diagonal elemnts equal and its
+*  off-diagonal elements of opposite sign.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for the
+*          cluster of eigenvalues (S) or the invariant subspace (SEP):
+*          = 'N': none;
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for invariant subspace only (SEP);
+*          = 'B': for both eigenvalues and invariant subspace (S and
+*                 SEP).
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'V': update the matrix Q of Schur vectors;
+*          = 'N': do not update Q.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          SELECT specifies the eigenvalues in the selected cluster. To
+*          select a real eigenvalue w(j), SELECT(j) must be set to
+*          .TRUE.. To select a complex conjugate pair of eigenvalues
+*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+*          either SELECT(j) or SELECT(j+1) or both must be set to
+*          .TRUE.; a complex conjugate pair of eigenvalues must be
+*          either both included in the cluster or both excluded.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+*          On entry, the upper quasi-triangular matrix T, in Schur
+*          canonical form.
+*          On exit, T is overwritten by the reordered matrix T, again in
+*          Schur canonical form, with the selected eigenvalues in the
+*          leading diagonal blocks.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+*          On exit, if COMPQ = 'V', Q has been postmultiplied by the
+*          orthogonal transformation matrix which reorders T; the
+*          leading M columns of Q form an orthonormal basis for the
+*          specified invariant subspace.
+*          If COMPQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
+*
+*  WR      (output) DOUBLE PRECISION array, dimension (N)
+*  WI      (output) DOUBLE PRECISION array, dimension (N)
+*          The real and imaginary parts, respectively, of the reordered
+*          eigenvalues of T. The eigenvalues are stored in the same
+*          order as on the diagonal of T, with WR(i) = T(i,i) and, if
+*          T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
+*          WI(i+1) = -WI(i). Note that if a complex eigenvalue is
+*          sufficiently ill-conditioned, then its value may differ
+*          significantly from its value before reordering.
+*
+*  M       (output) INTEGER
+*          The dimension of the specified invariant subspace.
+*          0 < = M <= N.
+*
+*  S       (output) DOUBLE PRECISION
+*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+*          condition number for the selected cluster of eigenvalues.
+*          S cannot underestimate the true reciprocal condition number
+*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+*          If JOB = 'N' or 'V', S is not referenced.
+*
+*  SEP     (output) DOUBLE PRECISION
+*          If JOB = 'V' or 'B', SEP is the estimated reciprocal
+*          condition number of the specified invariant subspace. If
+*          M = 0 or N, SEP = norm(T).
+*          If JOB = 'N' or 'E', SEP is not referenced.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If JOB = 'N', LWORK >= max(1,N);
+*          if JOB = 'E', LWORK >= max(1,M*(N-M));
+*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK.
+*          If JOB = 'N' or 'E', LIWORK >= 1;
+*          if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          = 1: reordering of T failed because some eigenvalues are too
+*               close to separate (the problem is very ill-conditioned);
+*               T may have been partially reordered, and WR and WI
+*               contain the eigenvalues in the same order as in T; S and
+*               SEP (if requested) are set to zero.
+*
+*  Further Details
+*  ===============
+*
+*  DTRSEN first collects the selected eigenvalues by computing an
+*  orthogonal transformation Z to move them to the top left corner of T.
+*  In other words, the selected eigenvalues are the eigenvalues of T11
+*  in:
+*
+*                Z'*T*Z = ( T11 T12 ) n1
+*                         (  0  T22 ) n2
+*                            n1  n2
+*
+*  where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
+*  of Z span the specified invariant subspace of T.
+*
+*  If T has been obtained from the real Schur factorization of a matrix
+*  A = Q*T*Q', then the reordered real Schur factorization of A is given
+*  by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
+*  the corresponding invariant subspace of A.
+*
+*  The reciprocal condition number of the average of the eigenvalues of
+*  T11 may be returned in S. S lies between 0 (very badly conditioned)
+*  and 1 (very well conditioned). It is computed as follows. First we
+*  compute R so that
+*
+*                         P = ( I  R ) n1
+*                             ( 0  0 ) n2
+*                               n1 n2
+*
+*  is the projector on the invariant subspace associated with T11.
+*  R is the solution of the Sylvester equation:
+*
+*                        T11*R - R*T22 = T12.
+*
+*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
+*  the two-norm of M. Then S is computed as the lower bound
+*
+*                      (1 + F-norm(R)**2)**(-1/2)
+*
+*  on the reciprocal of 2-norm(P), the true reciprocal condition number.
+*  S cannot underestimate 1 / 2-norm(P) by more than a factor of
+*  sqrt(N).
+*
+*  An approximate error bound for the computed average of the
+*  eigenvalues of T11 is
+*
+*                         EPS * norm(T) / S
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal condition number of the right invariant subspace
+*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
+*  SEP is defined as the separation of T11 and T22:
+*
+*                     sep( T11, T22 ) = sigma-min( C )
+*
+*  where sigma-min(C) is the smallest singular value of the
+*  n1*n2-by-n1*n2 matrix
+*
+*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
+*
+*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
+*  product. We estimate sigma-min(C) by the reciprocal of an estimate of
+*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
+*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
+*
+*  When SEP is small, small changes in T can cause large changes in
+*  the invariant subspace. An approximate bound on the maximum angular
+*  error in the computed right invariant subspace is
+*
+*                      EPS * norm(T) / SEP
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
+     $                   WANTSP
+      INTEGER            IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
+     $                   NN
+      DOUBLE PRECISION   EST, RNORM, SCALE
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLANGE
+      EXTERNAL           LSAME, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+      WANTQ = LSAME( COMPQ, 'V' )
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -8
+      ELSE
+*
+*        Set M to the dimension of the specified invariant subspace,
+*        and test LWORK and LIWORK.
+*
+         M = 0
+         PAIR = .FALSE.
+         DO 10 K = 1, N
+            IF( PAIR ) THEN
+               PAIR = .FALSE.
+            ELSE
+               IF( K.LT.N ) THEN
+                  IF( T( K+1, K ).EQ.ZERO ) THEN
+                     IF( SELECT( K ) )
+     $                  M = M + 1
+                  ELSE
+                     PAIR = .TRUE.
+                     IF( SELECT( K ) .OR. SELECT( K+1 ) )
+     $                  M = M + 2
+                  END IF
+               ELSE
+                  IF( SELECT( N ) )
+     $               M = M + 1
+               END IF
+            END IF
+   10    CONTINUE
+*
+         N1 = M
+         N2 = N - M
+         NN = N1*N2
+*
+         IF( WANTSP ) THEN
+            LWMIN = MAX( 1, 2*NN )
+            LIWMIN = MAX( 1, NN )
+         ELSE IF( LSAME( JOB, 'N' ) ) THEN
+            LWMIN = MAX( 1, N )
+            LIWMIN = 1
+         ELSE IF( LSAME( JOB, 'E' ) ) THEN
+            LWMIN = MAX( 1, NN )
+            LIWMIN = 1
+         END IF
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -15
+         ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -17
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+         IWORK( 1 ) = LIWMIN
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRSEN', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.N .OR. M.EQ.0 ) THEN
+         IF( WANTS )
+     $      S = ONE
+         IF( WANTSP )
+     $      SEP = DLANGE( '1', N, N, T, LDT, WORK )
+         GO TO 40
+      END IF
+*
+*     Collect the selected blocks at the top-left corner of T.
+*
+      KS = 0
+      PAIR = .FALSE.
+      DO 20 K = 1, N
+         IF( PAIR ) THEN
+            PAIR = .FALSE.
+         ELSE
+            SWAP = SELECT( K )
+            IF( K.LT.N ) THEN
+               IF( T( K+1, K ).NE.ZERO ) THEN
+                  PAIR = .TRUE.
+                  SWAP = SWAP .OR. SELECT( K+1 )
+               END IF
+            END IF
+            IF( SWAP ) THEN
+               KS = KS + 1
+*
+*              Swap the K-th block to position KS.
+*
+               IERR = 0
+               KK = K
+               IF( K.NE.KS )
+     $            CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK,
+     $                         IERR )
+               IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+*                 Blocks too close to swap: exit.
+*
+                  INFO = 1
+                  IF( WANTS )
+     $               S = ZERO
+                  IF( WANTSP )
+     $               SEP = ZERO
+                  GO TO 40
+               END IF
+               IF( PAIR )
+     $            KS = KS + 1
+            END IF
+         END IF
+   20 CONTINUE
+*
+      IF( WANTS ) THEN
+*
+*        Solve Sylvester equation for R:
+*
+*           T11*R - R*T22 = scale*T12
+*
+         CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+         CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
+     $                LDT, WORK, N1, SCALE, IERR )
+*
+*        Estimate the reciprocal of the condition number of the cluster
+*        of eigenvalues.
+*
+         RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK )
+         IF( RNORM.EQ.ZERO ) THEN
+            S = ONE
+         ELSE
+            S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
+     $          SQRT( RNORM ) )
+         END IF
+      END IF
+*
+      IF( WANTSP ) THEN
+*
+*        Estimate sep(T11,T22).
+*
+         EST = ZERO
+         KASE = 0
+   30    CONTINUE
+         CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Solve  T11*R - R*T22 = scale*X.
+*
+               CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
+     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+     $                      IERR )
+            ELSE
+*
+*              Solve  T11'*R - R*T22' = scale*X.
+*
+               CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT,
+     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+     $                      IERR )
+            END IF
+            GO TO 30
+         END IF
+*
+         SEP = SCALE / EST
+      END IF
+*
+   40 CONTINUE
+*
+*     Store the output eigenvalues in WR and WI.
+*
+      DO 50 K = 1, N
+         WR( K ) = T( K, K )
+         WI( K ) = ZERO
+   50 CONTINUE
+      DO 60 K = 1, N - 1
+         IF( T( K+1, K ).NE.ZERO ) THEN
+            WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
+     $                SQRT( ABS( T( K+1, K ) ) )
+            WI( K+1 ) = -WI( K )
+         END IF
+   60 CONTINUE
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of DTRSEN
+*
+      END
diff --git a/src/lib/lapack/dtrsyl.f b/src/lib/lapack/dtrsyl.f
new file mode 100644
index 00000000..4c6c28e5
--- /dev/null
+++ b/src/lib/lapack/dtrsyl.f
@@ -0,0 +1,913 @@
+      SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+     $                   LDC, SCALE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANA, TRANB
+      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRSYL solves the real Sylvester matrix equation:
+*
+*     op(A)*X + X*op(B) = scale*C or
+*     op(A)*X - X*op(B) = scale*C,
+*
+*  where op(A) = A or A**T, and  A and B are both upper quasi-
+*  triangular. A is M-by-M and B is N-by-N; the right hand side C and
+*  the solution X are M-by-N; and scale is an output scale factor, set
+*  <= 1 to avoid overflow in X.
+*
+*  A and B must be in Schur canonical form (as returned by DHSEQR), that
+*  is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
+*  each 2-by-2 diagonal block has its diagonal elements equal and its
+*  off-diagonal elements of opposite sign.
+*
+*  Arguments
+*  =========
+*
+*  TRANA   (input) CHARACTER*1
+*          Specifies the option op(A):
+*          = 'N': op(A) = A    (No transpose)
+*          = 'T': op(A) = A**T (Transpose)
+*          = 'C': op(A) = A**H (Conjugate transpose = Transpose)
+*
+*  TRANB   (input) CHARACTER*1
+*          Specifies the option op(B):
+*          = 'N': op(B) = B    (No transpose)
+*          = 'T': op(B) = B**T (Transpose)
+*          = 'C': op(B) = B**H (Conjugate transpose = Transpose)
+*
+*  ISGN    (input) INTEGER
+*          Specifies the sign in the equation:
+*          = +1: solve op(A)*X + X*op(B) = scale*C
+*          = -1: solve op(A)*X - X*op(B) = scale*C
+*
+*  M       (input) INTEGER
+*          The order of the matrix A, and the number of rows in the
+*          matrices X and C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B, and the number of columns in the
+*          matrices X and C. N >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,M)
+*          The upper quasi-triangular matrix A, in Schur canonical form.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)
+*          The upper quasi-triangular matrix B, in Schur canonical form.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+*          On entry, the M-by-N right hand side matrix C.
+*          On exit, C is overwritten by the solution matrix X.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M)
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          The scale factor, scale, set <= 1 to avoid overflow in X.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          = 1: A and B have common or very close eigenvalues; perturbed
+*               values were used to solve the equation (but the matrices
+*               A and B are unchanged).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRNA, NOTRNB
+      INTEGER            IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
+      DOUBLE PRECISION   A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+     $                   SMLNUM, SUML, SUMR, XNORM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DDOT, DLAMCH, DLANGE
+      EXTERNAL           LSAME, DDOT, DLAMCH, DLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, DLALN2, DLASY2, DSCAL, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test input parameters
+*
+      NOTRNA = LSAME( TRANA, 'N' )
+      NOTRNB = LSAME( TRANB, 'N' )
+*
+      INFO = 0
+      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT.
+     $    LSAME( TRANA, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT.
+     $         LSAME( TRANB, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRSYL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM*DBLE( M*N ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+      SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ),
+     $       EPS*DLANGE( 'M', N, N, B, LDB, DUM ) )
+*
+      SCALE = ONE
+      SGN = ISGN
+*
+      IF( NOTRNA .AND. NOTRNB ) THEN
+*
+*        Solve    A*X + ISGN*X*B = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        bottom-left corner column by column by
+*
+*         A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                  M                         L-1
+*        R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
+*                I=K+1                       J=1
+*
+*        Start column loop (index = L)
+*        L1 (L2) : column index of the first (first) row of X(K,L).
+*
+         LNEXT = 1
+         DO 60 L = 1, N
+            IF( L.LT.LNEXT )
+     $         GO TO 60
+            IF( L.EQ.N ) THEN
+               L1 = L
+               L2 = L
+            ELSE
+               IF( B( L+1, L ).NE.ZERO ) THEN
+                  L1 = L
+                  L2 = L + 1
+                  LNEXT = L + 2
+               ELSE
+                  L1 = L
+                  L2 = L
+                  LNEXT = L + 1
+               END IF
+            END IF
+*
+*           Start row loop (index = K)
+*           K1 (K2): row index of the first (last) row of X(K,L).
+*
+            KNEXT = M
+            DO 50 K = M, 1, -1
+               IF( K.GT.KNEXT )
+     $            GO TO 50
+               IF( K.EQ.1 ) THEN
+                  K1 = K
+                  K2 = K
+               ELSE
+                  IF( A( K, K-1 ).NE.ZERO ) THEN
+                     K1 = K - 1
+                     K2 = K
+                     KNEXT = K - 2
+                  ELSE
+                     K1 = K
+                     K2 = K
+                     KNEXT = K - 1
+                  END IF
+               END IF
+*
+               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+                  SCALOC = ONE
+*
+                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+                  DA11 = ABS( A11 )
+                  IF( DA11.LE.SMIN ) THEN
+                     A11 = SMIN
+                     DA11 = SMIN
+                     INFO = 1
+                  END IF
+                  DB = ABS( VEC( 1, 1 ) )
+                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                     IF( DB.GT.BIGNUM*DA11 )
+     $                  SCALOC = ONE / DB
+                  END IF
+                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 10 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   10                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+     $                         LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 20 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   20                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K2, L1 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+     $                         LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 30 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   30                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2,
+     $                         A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
+     $                         2, SCALOC, X, 2, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 40 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   40                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 1, 2 )
+                  C( K2, L1 ) = X( 2, 1 )
+                  C( K2, L2 ) = X( 2, 2 )
+               END IF
+*
+   50       CONTINUE
+*
+   60    CONTINUE
+*
+      ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
+*
+*        Solve    A' *X + ISGN*X*B = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        upper-left corner column by column by
+*
+*          A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                   K-1                        L-1
+*          R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
+*                   I=1                        J=1
+*
+*        Start column loop (index = L)
+*        L1 (L2): column index of the first (last) row of X(K,L)
+*
+         LNEXT = 1
+         DO 120 L = 1, N
+            IF( L.LT.LNEXT )
+     $         GO TO 120
+            IF( L.EQ.N ) THEN
+               L1 = L
+               L2 = L
+            ELSE
+               IF( B( L+1, L ).NE.ZERO ) THEN
+                  L1 = L
+                  L2 = L + 1
+                  LNEXT = L + 2
+               ELSE
+                  L1 = L
+                  L2 = L
+                  LNEXT = L + 1
+               END IF
+            END IF
+*
+*           Start row loop (index = K)
+*           K1 (K2): row index of the first (last) row of X(K,L)
+*
+            KNEXT = 1
+            DO 110 K = 1, M
+               IF( K.LT.KNEXT )
+     $            GO TO 110
+               IF( K.EQ.M ) THEN
+                  K1 = K
+                  K2 = K
+               ELSE
+                  IF( A( K+1, K ).NE.ZERO ) THEN
+                     K1 = K
+                     K2 = K + 1
+                     KNEXT = K + 2
+                  ELSE
+                     K1 = K
+                     K2 = K
+                     KNEXT = K + 1
+                  END IF
+               END IF
+*
+               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+                  SCALOC = ONE
+*
+                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+                  DA11 = ABS( A11 )
+                  IF( DA11.LE.SMIN ) THEN
+                     A11 = SMIN
+                     DA11 = SMIN
+                     INFO = 1
+                  END IF
+                  DB = ABS( VEC( 1, 1 ) )
+                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                     IF( DB.GT.BIGNUM*DA11 )
+     $                  SCALOC = ONE / DB
+                  END IF
+                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 70 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   70                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+     $                         LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 80 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   80                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K2, L1 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+     $                         LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 90 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+   90                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
+     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+     $                         2, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 100 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  100                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 1, 2 )
+                  C( K2, L1 ) = X( 2, 1 )
+                  C( K2, L2 ) = X( 2, 2 )
+               END IF
+*
+  110       CONTINUE
+  120    CONTINUE
+*
+      ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+*        Solve    A'*X + ISGN*X*B' = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        top-right corner column by column by
+*
+*           A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+*        Where
+*                     K-1                          N
+*            R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+*                     I=1                        J=L+1
+*
+*        Start column loop (index = L)
+*        L1 (L2): column index of the first (last) row of X(K,L)
+*
+         LNEXT = N
+         DO 180 L = N, 1, -1
+            IF( L.GT.LNEXT )
+     $         GO TO 180
+            IF( L.EQ.1 ) THEN
+               L1 = L
+               L2 = L
+            ELSE
+               IF( B( L, L-1 ).NE.ZERO ) THEN
+                  L1 = L - 1
+                  L2 = L
+                  LNEXT = L - 2
+               ELSE
+                  L1 = L
+                  L2 = L
+                  LNEXT = L - 1
+               END IF
+            END IF
+*
+*           Start row loop (index = K)
+*           K1 (K2): row index of the first (last) row of X(K,L)
+*
+            KNEXT = 1
+            DO 170 K = 1, M
+               IF( K.LT.KNEXT )
+     $            GO TO 170
+               IF( K.EQ.M ) THEN
+                  K1 = K
+                  K2 = K
+               ELSE
+                  IF( A( K+1, K ).NE.ZERO ) THEN
+                     K1 = K
+                     K2 = K + 1
+                     KNEXT = K + 2
+                  ELSE
+                     K1 = K
+                     K2 = K
+                     KNEXT = K + 1
+                  END IF
+               END IF
+*
+               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+     $                   B( L1, MIN( L1+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+                  SCALOC = ONE
+*
+                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+                  DA11 = ABS( A11 )
+                  IF( DA11.LE.SMIN ) THEN
+                     A11 = SMIN
+                     DA11 = SMIN
+                     INFO = 1
+                  END IF
+                  DB = ABS( VEC( 1, 1 ) )
+                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                     IF( DB.GT.BIGNUM*DA11 )
+     $                  SCALOC = ONE / DB
+                  END IF
+                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 130 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  130                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+     $                         LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 140 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  140                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K2, L1 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+     $                         LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 150 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  150                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+     $                         2, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 160 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  160                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 1, 2 )
+                  C( K2, L1 ) = X( 2, 1 )
+                  C( K2, L2 ) = X( 2, 2 )
+               END IF
+*
+  170       CONTINUE
+  180    CONTINUE
+*
+      ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+*        Solve    A*X + ISGN*X*B' = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        bottom-right corner column by column by
+*
+*            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+*        Where
+*                      M                          N
+*            R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+*                    I=K+1                      J=L+1
+*
+*        Start column loop (index = L)
+*        L1 (L2): column index of the first (last) row of X(K,L)
+*
+         LNEXT = N
+         DO 240 L = N, 1, -1
+            IF( L.GT.LNEXT )
+     $         GO TO 240
+            IF( L.EQ.1 ) THEN
+               L1 = L
+               L2 = L
+            ELSE
+               IF( B( L, L-1 ).NE.ZERO ) THEN
+                  L1 = L - 1
+                  L2 = L
+                  LNEXT = L - 2
+               ELSE
+                  L1 = L
+                  L2 = L
+                  LNEXT = L - 1
+               END IF
+            END IF
+*
+*           Start row loop (index = K)
+*           K1 (K2): row index of the first (last) row of X(K,L)
+*
+            KNEXT = M
+            DO 230 K = M, 1, -1
+               IF( K.GT.KNEXT )
+     $            GO TO 230
+               IF( K.EQ.1 ) THEN
+                  K1 = K
+                  K2 = K
+               ELSE
+                  IF( A( K, K-1 ).NE.ZERO ) THEN
+                     K1 = K - 1
+                     K2 = K
+                     KNEXT = K - 2
+                  ELSE
+                     K1 = K
+                     K2 = K
+                     KNEXT = K - 1
+                  END IF
+               END IF
+*
+               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+     $                   B( L1, MIN( L1+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+                  SCALOC = ONE
+*
+                  A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+                  DA11 = ABS( A11 )
+                  IF( DA11.LE.SMIN ) THEN
+                     A11 = SMIN
+                     DA11 = SMIN
+                     INFO = 1
+                  END IF
+                  DB = ABS( VEC( 1, 1 ) )
+                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                     IF( DB.GT.BIGNUM*DA11 )
+     $                  SCALOC = ONE / DB
+                  END IF
+                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 190 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  190                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+*
+               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+     $                         LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 200 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  200                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K2, L1 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+                  SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+     $                   C( MIN( K1+1, M ), L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+     $                         LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 210 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  210                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 2, 1 )
+*
+               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L1 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L1, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+                  SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+     $                   C( MIN( K2+1, M ), L2 ), 1 )
+                  SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+     $                   B( L2, MIN( L2+1, N ) ), LDB )
+                  VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+                  CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+     $                         LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+     $                         2, XNORM, IERR )
+                  IF( IERR.NE.0 )
+     $               INFO = 1
+*
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 220 J = 1, N
+                        CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+  220                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+                  C( K1, L1 ) = X( 1, 1 )
+                  C( K1, L2 ) = X( 1, 2 )
+                  C( K2, L1 ) = X( 2, 1 )
+                  C( K2, L2 ) = X( 2, 2 )
+               END IF
+*
+  230       CONTINUE
+  240    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of DTRSYL
+*
+      END
diff --git a/src/lib/lapack/dtrti2.f b/src/lib/lapack/dtrti2.f
new file mode 100644
index 00000000..e7ae764d
--- /dev/null
+++ b/src/lib/lapack/dtrti2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRTI2 computes the inverse of a real upper or lower triangular
+*  matrix.
+*
+*  This is the Level 2 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the matrix A is upper or lower triangular.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  DIAG    (input) CHARACTER*1
+*          Specifies whether or not the matrix A is unit triangular.
+*          = 'N':  Non-unit triangular
+*          = 'U':  Unit triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the triangular matrix A.  If UPLO = 'U', the
+*          leading n by n upper triangular part of the array A contains
+*          the upper triangular matrix, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of the array A contains
+*          the lower triangular matrix, and the strictly upper
+*          triangular part of A is not referenced.  If DIAG = 'U', the
+*          diagonal elements of A are also not referenced and are
+*          assumed to be 1.
+*
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same storage format.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DTRMV, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRTI2', -INFO )
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         DO 10 J = 1, N
+            IF( NOUNIT ) THEN
+               A( J, J ) = ONE / A( J, J )
+               AJJ = -A( J, J )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+     $                  A( 1, J ), 1 )
+            CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         DO 20 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               A( J, J ) = ONE / A( J, J )
+               AJJ = -A( J, J )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+               CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DTRTI2
+*
+      END
diff --git a/src/lib/lapack/dtrtri.f b/src/lib/lapack/dtrtri.f
new file mode 100644
index 00000000..375813c6
--- /dev/null
+++ b/src/lib/lapack/dtrtri.f
@@ -0,0 +1,176 @@
+      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRTRI computes the inverse of a real upper or lower triangular
+*  matrix A.
+*
+*  This is the Level 3 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  DIAG    (input) CHARACTER*1
+*          = 'N':  A is non-unit triangular;
+*          = 'U':  A is unit triangular.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the triangular matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of the array A contains
+*          the upper triangular matrix, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of the array A contains
+*          the lower triangular matrix, and the strictly upper
+*          triangular part of A is not referenced.  If DIAG = 'U', the
+*          diagonal elements of A are also not referenced and are
+*          assumed to be 1.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same storage format.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
+*               matrix is singular and its inverse can not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JB, NB, NN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTRMM, DTRSM, DTRTI2, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         DO 10 INFO = 1, N
+            IF( A( INFO, INFO ).EQ.ZERO )
+     $         RETURN
+   10    CONTINUE
+         INFO = 0
+      END IF
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute inverse of upper triangular matrix
+*
+            DO 20 J = 1, N, NB
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute rows 1:j-1 of current block column
+*
+               CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
+               CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+*              Compute inverse of current diagonal block
+*
+               CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
+   20       CONTINUE
+         ELSE
+*
+*           Compute inverse of lower triangular matrix
+*
+            NN = ( ( N-1 ) / NB )*NB + 1
+            DO 30 J = NN, 1, -NB
+               JB = MIN( NB, N-J+1 )
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute rows j+jb:n of current block column
+*
+                  CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+     $                        A( J+JB, J ), LDA )
+                  CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
+     $                        A( J+JB, J ), LDA )
+               END IF
+*
+*              Compute inverse of current diagonal block
+*
+               CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+   30       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRTRI
+*
+      END
diff --git a/src/lib/lapack/dtrtrs.f b/src/lib/lapack/dtrtrs.f
new file mode 100644
index 00000000..139ea6d4
--- /dev/null
+++ b/src/lib/lapack/dtrtrs.f
@@ -0,0 +1,147 @@
+      SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, TRANS, UPLO
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRTRS solves a triangular system of the form
+*
+*     A * X = B  or  A**T * X = B,
+*
+*  where A is a triangular matrix of order N, and B is an N-by-NRHS
+*  matrix.  A check is made to verify that A is nonsingular.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form of the system of equations:
+*          = 'N':  A * X = B  (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
+*
+*  DIAG    (input) CHARACTER*1
+*          = 'N':  A is non-unit triangular;
+*          = 'U':  A is unit triangular.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
+*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N
+*          upper triangular part of the array A contains the upper
+*          triangular matrix, and the strictly lower triangular part of
+*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower
+*          triangular part of the array A contains the lower triangular
+*          matrix, and the strictly upper triangular part of A is not
+*          referenced.  If DIAG = 'U', the diagonal elements of A are
+*          also not referenced and are assumed to be 1.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit, if INFO = 0, the solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, the i-th diagonal element of A is zero,
+*               indicating that the matrix is singular and the solutions
+*               X have not been computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DTRSM, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+     $         LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTRTRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity.
+*
+      IF( NOUNIT ) THEN
+         DO 10 INFO = 1, N
+            IF( A( INFO, INFO ).EQ.ZERO )
+     $         RETURN
+   10    CONTINUE
+      END IF
+      INFO = 0
+*
+*     Solve A * x = b  or  A' * x = b.
+*
+      CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+     $            LDB )
+*
+      RETURN
+*
+*     End of DTRTRS
+*
+      END
diff --git a/src/lib/lapack/dtzrqf.f b/src/lib/lapack/dtzrqf.f
new file mode 100644
index 00000000..5555df38
--- /dev/null
+++ b/src/lib/lapack/dtzrqf.f
@@ -0,0 +1,164 @@
+      SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine DTZRZF.
+*
+*  DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+*  to upper triangular form by means of orthogonal transformations.
+*
+*  The upper trapezoidal matrix A is factored as
+*
+*     A = ( R  0 ) * Z,
+*
+*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+*  triangular matrix.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= M.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the leading M-by-N upper trapezoidal part of the
+*          array A must contain the matrix to be factorized.
+*          On exit, the leading M-by-M upper triangular part of A
+*          contains the upper triangular matrix R, and elements M+1 to
+*          N of the first M rows of A, with the array TAU, represent the
+*          orthogonal matrix Z as a product of M elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The factorization is obtained by Householder's method.  The kth
+*  transformation matrix, Z( k ), which is used to introduce zeros into
+*  the ( m - k + 1 )th row of A, is given in the form
+*
+*     Z( k ) = ( I     0   ),
+*              ( 0  T( k ) )
+*
+*  where
+*
+*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
+*                                                 (   0    )
+*                                                 ( z( k ) )
+*
+*  tau is a scalar and z( k ) is an ( n - m ) element vector.
+*  tau and z( k ) are chosen to annihilate the elements of the kth row
+*  of X.
+*
+*  The scalar tau is returned in the kth element of TAU and the vector
+*  u( k ) in the kth row of A, such that the elements of z( k ) are
+*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+*  the upper triangular part of A.
+*
+*  Z is given by
+*
+*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K, M1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTZRQF', -INFO )
+         RETURN
+      END IF
+*
+*     Perform the factorization.
+*
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = ZERO
+   10    CONTINUE
+      ELSE
+         M1 = MIN( M+1, N )
+         DO 20 K = M, 1, -1
+*
+*           Use a Householder reflection to zero the kth row of A.
+*           First set up the reflection.
+*
+            CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
+*
+            IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
+*
+*              We now perform the operation  A := A*P( k ).
+*
+*              Use the first ( k - 1 ) elements of TAU to store  a( k ),
+*              where  a( k ) consists of the first ( k - 1 ) elements of
+*              the  kth column  of  A.  Also  let  B  denote  the  first
+*              ( k - 1 ) rows of the last ( n - m ) columns of A.
+*
+               CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+*              Form   w = a( k ) + B*z( k )  in TAU.
+*
+               CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
+     $                     LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
+*
+*              Now form  a( k ) := a( k ) - tau*w
+*              and       B      := B      - tau*w*z( k )'.
+*
+               CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
+               CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
+     $                    A( 1, M1 ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DTZRQF
+*
+      END
diff --git a/src/lib/lapack/dtzrzf.f b/src/lib/lapack/dtzrzf.f
new file mode 100644
index 00000000..378eefe1
--- /dev/null
+++ b/src/lib/lapack/dtzrzf.f
@@ -0,0 +1,244 @@
+      SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+*  to upper triangular form by means of orthogonal transformations.
+*
+*  The upper trapezoidal matrix A is factored as
+*
+*     A = ( R  0 ) * Z,
+*
+*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+*  triangular matrix.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= M.
+*
+*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+*          On entry, the leading M-by-N upper trapezoidal part of the
+*          array A must contain the matrix to be factorized.
+*          On exit, the leading M-by-M upper triangular part of A
+*          contains the upper triangular matrix R, and elements M+1 to
+*          N of the first M rows of A, with the array TAU, represent the
+*          orthogonal matrix Z as a product of M elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) DOUBLE PRECISION array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The factorization is obtained by Householder's method.  The kth
+*  transformation matrix, Z( k ), which is used to introduce zeros into
+*  the ( m - k + 1 )th row of A, is given in the form
+*
+*     Z( k ) = ( I     0   ),
+*              ( 0  T( k ) )
+*
+*  where
+*
+*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
+*                                                 (   0    )
+*                                                 ( z( k ) )
+*
+*  tau is a scalar and z( k ) is an ( n - m ) element vector.
+*  tau and z( k ) are chosen to annihilate the elements of the kth row
+*  of X.
+*
+*  The scalar tau is returned in the kth element of TAU and the vector
+*  u( k ) in the kth row of A, such that the elements of z( k ) are
+*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+*  the upper triangular part of A.
+*
+*  Z is given by
+*
+*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARZB, DLARZT, DLATRZ, XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. M.EQ.N ) THEN
+            LWKOPT = 1
+         ELSE
+*
+*           Determine the block size.
+*
+            NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+            LWKOPT = M*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+            INFO = -7
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'DTZRZF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 1
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.M ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.M ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
+*
+*        Use blocked code initially.
+*        The last kk rows are handled by the block method.
+*
+         M1 = MIN( M+1, N )
+         KI = ( ( M-NX-1 ) / NB )*NB
+         KK = MIN( M, KI+NB )
+*
+         DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
+            IB = MIN( M-I+1, NB )
+*
+*           Compute the TZ factorization of the current block
+*           A(i:i+ib-1,i:n)
+*
+            CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
+     $                   WORK )
+            IF( I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(1:i-1,i:n) from the right
+*
+               CALL DLARZB( 'Right', 'No transpose', 'Backward',
+     $                      'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
+     $                      LDA, WORK, LDWORK, A( 1, I ), LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   20    CONTINUE
+         MU = I + NB - 1
+      ELSE
+         MU = M
+      END IF
+*
+*     Use unblocked code to factor the last or only block
+*
+      IF( MU.GT.0 )
+     $   CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of DTZRZF
+*
+      END
diff --git a/src/lib/lapack/dzsum1.f b/src/lib/lapack/dzsum1.f
new file mode 100644
index 00000000..0b6c60e7
--- /dev/null
+++ b/src/lib/lapack/dzsum1.f
@@ -0,0 +1,81 @@
+      DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DZSUM1 takes the sum of the absolute values of a complex
+*  vector and returns a double precision result.
+*
+*  Based on DZASUM from the Level 1 BLAS.
+*  The change is to use the 'genuine' absolute value.
+*
+*  Contributed by Nick Higham for use with ZLACON.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vector CX.
+*
+*  CX      (input) COMPLEX*16 array, dimension (N)
+*          The vector whose elements will be summed.
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive values of CX.  INCX > 0.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, NINCX
+      DOUBLE PRECISION   STEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+      DZSUM1 = 0.0D0
+      STEMP = 0.0D0
+      IF( N.LE.0 )
+     $   RETURN
+      IF( INCX.EQ.1 )
+     $   GO TO 20
+*
+*     CODE FOR INCREMENT NOT EQUAL TO 1
+*
+      NINCX = N*INCX
+      DO 10 I = 1, NINCX, INCX
+*
+*        NEXT LINE MODIFIED.
+*
+         STEMP = STEMP + ABS( CX( I ) )
+   10 CONTINUE
+      DZSUM1 = STEMP
+      RETURN
+*
+*     CODE FOR INCREMENT EQUAL TO 1
+*
+   20 CONTINUE
+      DO 30 I = 1, N
+*
+*        NEXT LINE MODIFIED.
+*
+         STEMP = STEMP + ABS( CX( I ) )
+   30 CONTINUE
+      DZSUM1 = STEMP
+      RETURN
+*
+*     End of DZSUM1
+*
+      END
diff --git a/src/lib/lapack/ieeeck.f b/src/lib/lapack/ieeeck.f
new file mode 100644
index 00000000..ac4aff85
--- /dev/null
+++ b/src/lib/lapack/ieeeck.f
@@ -0,0 +1,147 @@
+      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            ISPEC
+      REAL               ONE, ZERO
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  IEEECK is called from the ILAENV to verify that Infinity and
+*  possibly NaN arithmetic is safe (i.e. will not trap).
+*
+*  Arguments
+*  =========
+*
+*  ISPEC   (input) INTEGER
+*          Specifies whether to test just for inifinity arithmetic
+*          or whether to test for infinity and NaN arithmetic.
+*          = 0: Verify infinity arithmetic only.
+*          = 1: Verify infinity and NaN arithmetic.
+*
+*  ZERO    (input) REAL
+*          Must contain the value 0.0
+*          This is passed to prevent the compiler from optimizing
+*          away this code.
+*
+*  ONE     (input) REAL
+*          Must contain the value 1.0
+*          This is passed to prevent the compiler from optimizing
+*          away this code.
+*
+*  RETURN VALUE:  INTEGER
+*          = 0:  Arithmetic failed to produce the correct answers
+*          = 1:  Arithmetic produced the correct answers
+*
+*     .. Local Scalars ..
+      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
+     $                   NEGZRO, NEWZRO, POSINF
+*     ..
+*     .. Executable Statements ..
+      IEEECK = 1
+*
+      POSINF = ONE / ZERO
+      IF( POSINF.LE.ONE ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      NEGINF = -ONE / ZERO
+      IF( NEGINF.GE.ZERO ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      NEGZRO = ONE / ( NEGINF+ONE )
+      IF( NEGZRO.NE.ZERO ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      NEGINF = ONE / NEGZRO
+      IF( NEGINF.GE.ZERO ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      NEWZRO = NEGZRO + ZERO
+      IF( NEWZRO.NE.ZERO ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      POSINF = ONE / NEWZRO
+      IF( POSINF.LE.ONE ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      NEGINF = NEGINF*POSINF
+      IF( NEGINF.GE.ZERO ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      POSINF = POSINF*POSINF
+      IF( POSINF.LE.ONE ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+*
+*
+*
+*     Return if we were only asked to check infinity arithmetic
+*
+      IF( ISPEC.EQ.0 )
+     $   RETURN
+*
+      NAN1 = POSINF + NEGINF
+*
+      NAN2 = POSINF / NEGINF
+*
+      NAN3 = POSINF / POSINF
+*
+      NAN4 = POSINF*ZERO
+*
+      NAN5 = NEGINF*NEGZRO
+*
+      NAN6 = NAN5*0.0
+*
+      IF( NAN1.EQ.NAN1 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      IF( NAN2.EQ.NAN2 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      IF( NAN3.EQ.NAN3 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      IF( NAN4.EQ.NAN4 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      IF( NAN5.EQ.NAN5 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      IF( NAN6.EQ.NAN6 ) THEN
+         IEEECK = 0
+         RETURN
+      END IF
+*
+      RETURN
+      END
diff --git a/src/lib/lapack/ilaenv.f b/src/lib/lapack/ilaenv.f
new file mode 100644
index 00000000..c375031b
--- /dev/null
+++ b/src/lib/lapack/ilaenv.f
@@ -0,0 +1,552 @@
+      INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER*( * )    NAME, OPTS
+      INTEGER            ISPEC, N1, N2, N3, N4
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ILAENV is called from the LAPACK routines to choose problem-dependent
+*  parameters for the local environment.  See ISPEC for a description of
+*  the parameters.
+*
+*  This version provides a set of parameters which should give good,
+*  but not optimal, performance on many of the currently available
+*  computers.  Users are encouraged to modify this subroutine to set
+*  the tuning parameters for their particular machine using the option
+*  and problem size information in the arguments.
+*
+*  This routine will not function correctly if it is converted to all
+*  lower case.  Converting it to all upper case is allowed.
+*
+*  Arguments
+*  =========
+*
+*  ISPEC   (input) INTEGER
+*          Specifies the parameter to be returned as the value of
+*          ILAENV.
+*          = 1: the optimal blocksize; if this value is 1, an unblocked
+*               algorithm will give the best performance.
+*          = 2: the minimum block size for which the block routine
+*               should be used; if the usable block size is less than
+*               this value, an unblocked routine should be used.
+*          = 3: the crossover point (in a block routine, for N less
+*               than this value, an unblocked routine should be used)
+*          = 4: the number of shifts, used in the nonsymmetric
+*               eigenvalue routines (DEPRECATED)
+*          = 5: the minimum column dimension for blocking to be used;
+*               rectangular blocks must have dimension at least k by m,
+*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)
+*          = 6: the crossover point for the SVD (when reducing an m by n
+*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+*               this value, a QR factorization is used first to reduce
+*               the matrix to a triangular form.)
+*          = 7: the number of processors
+*          = 8: the crossover point for the multishift QR method
+*               for nonsymmetric eigenvalue problems (DEPRECATED)
+*          = 9: maximum size of the subproblems at the bottom of the
+*               computation tree in the divide-and-conquer algorithm
+*               (used by xGELSD and xGESDD)
+*          =10: ieee NaN arithmetic can be trusted not to trap
+*          =11: infinity arithmetic can be trusted not to trap
+*          12 <= ISPEC <= 16:
+*               xHSEQR or one of its subroutines,
+*               see IPARMQ for detailed explanation
+*
+*  NAME    (input) CHARACTER*(*)
+*          The name of the calling subroutine, in either upper case or
+*          lower case.
+*
+*  OPTS    (input) CHARACTER*(*)
+*          The character options to the subroutine NAME, concatenated
+*          into a single character string.  For example, UPLO = 'U',
+*          TRANS = 'T', and DIAG = 'N' for a triangular routine would
+*          be specified as OPTS = 'UTN'.
+*
+*  N1      (input) INTEGER
+*  N2      (input) INTEGER
+*  N3      (input) INTEGER
+*  N4      (input) INTEGER
+*          Problem dimensions for the subroutine NAME; these may not all
+*          be required.
+*
+* (ILAENV) (output) INTEGER
+*          >= 0: the value of the parameter specified by ISPEC
+*          < 0:  if ILAENV = -k, the k-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The following conventions have been used when calling ILAENV from the
+*  LAPACK routines:
+*  1)  OPTS is a concatenation of all of the character options to
+*      subroutine NAME, in the same order that they appear in the
+*      argument list for NAME, even if they are not used in determining
+*      the value of the parameter specified by ISPEC.
+*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order
+*      that they appear in the argument list for NAME.  N1 is used
+*      first, N2 second, and so on, and unused problem dimensions are
+*      passed a value of -1.
+*  3)  The parameter value returned by ILAENV is checked for validity in
+*      the calling subroutine.  For example, ILAENV is used to retrieve
+*      the optimal blocksize for STRTRI as follows:
+*
+*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+*      IF( NB.LE.1 ) NB = MAX( 1, N )
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IC, IZ, NB, NBMIN, NX
+      LOGICAL            CNAME, SNAME
+      CHARACTER          C1*1, C2*2, C4*2, C3*3, SUBNAM*6
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
+*     ..
+*     .. External Functions ..
+      INTEGER            IEEECK, IPARMQ
+      EXTERNAL           IEEECK, IPARMQ
+*     ..
+*     .. Executable Statements ..
+*
+      GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
+     $        130, 140, 150, 160, 160, 160, 160, 160 )ISPEC
+*
+*     Invalid value for ISPEC
+*
+      ILAENV = -1
+      RETURN
+*
+   10 CONTINUE
+*
+*     Convert NAME to upper case if the first character is lower case.
+*
+      ILAENV = 1
+      SUBNAM = NAME
+      IC = ICHAR( SUBNAM( 1: 1 ) )
+      IZ = ICHAR( 'Z' )
+      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
+*
+*        ASCII character set
+*
+         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
+            SUBNAM( 1: 1 ) = CHAR( IC-32 )
+            DO 20 I = 2, 6
+               IC = ICHAR( SUBNAM( I: I ) )
+               IF( IC.GE.97 .AND. IC.LE.122 )
+     $            SUBNAM( I: I ) = CHAR( IC-32 )
+   20       CONTINUE
+         END IF
+*
+      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
+*
+*        EBCDIC character set
+*
+         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+     $       ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+     $       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
+            SUBNAM( 1: 1 ) = CHAR( IC+64 )
+            DO 30 I = 2, 6
+               IC = ICHAR( SUBNAM( I: I ) )
+               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+     $             ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+     $             ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
+     $             I ) = CHAR( IC+64 )
+   30       CONTINUE
+         END IF
+*
+      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
+*
+*        Prime machines:  ASCII+128
+*
+         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
+            SUBNAM( 1: 1 ) = CHAR( IC-32 )
+            DO 40 I = 2, 6
+               IC = ICHAR( SUBNAM( I: I ) )
+               IF( IC.GE.225 .AND. IC.LE.250 )
+     $            SUBNAM( I: I ) = CHAR( IC-32 )
+   40       CONTINUE
+         END IF
+      END IF
+*
+      C1 = SUBNAM( 1: 1 )
+      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
+      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
+      IF( .NOT.( CNAME .OR. SNAME ) )
+     $   RETURN
+      C2 = SUBNAM( 2: 3 )
+      C3 = SUBNAM( 4: 6 )
+      C4 = C3( 2: 3 )
+*
+      GO TO ( 50, 60, 70 )ISPEC
+*
+   50 CONTINUE
+*
+*     ISPEC = 1:  block size
+*
+*     In these examples, separate code is provided for setting NB for
+*     real and complex.  We assume that NB will take the same value in
+*     single or double precision.
+*
+      NB = 1
+*
+      IF( C2.EQ.'GE' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
+     $            C3.EQ.'QLF' ) THEN
+            IF( SNAME ) THEN
+               NB = 32
+            ELSE
+               NB = 32
+            END IF
+         ELSE IF( C3.EQ.'HRD' ) THEN
+            IF( SNAME ) THEN
+               NB = 32
+            ELSE
+               NB = 32
+            END IF
+         ELSE IF( C3.EQ.'BRD' ) THEN
+            IF( SNAME ) THEN
+               NB = 32
+            ELSE
+               NB = 32
+            END IF
+         ELSE IF( C3.EQ.'TRI' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'PO' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'SY' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+            NB = 32
+         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
+            NB = 64
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            NB = 64
+         ELSE IF( C3.EQ.'TRD' ) THEN
+            NB = 32
+         ELSE IF( C3.EQ.'GST' ) THEN
+            NB = 64
+         END IF
+      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NB = 32
+            END IF
+         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NB = 32
+            END IF
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NB = 32
+            END IF
+         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NB = 32
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'GB' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               IF( N4.LE.64 ) THEN
+                  NB = 1
+               ELSE
+                  NB = 32
+               END IF
+            ELSE
+               IF( N4.LE.64 ) THEN
+                  NB = 1
+               ELSE
+                  NB = 32
+               END IF
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'PB' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               IF( N2.LE.64 ) THEN
+                  NB = 1
+               ELSE
+                  NB = 32
+               END IF
+            ELSE
+               IF( N2.LE.64 ) THEN
+                  NB = 1
+               ELSE
+                  NB = 32
+               END IF
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'TR' ) THEN
+         IF( C3.EQ.'TRI' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'LA' ) THEN
+         IF( C3.EQ.'UUM' ) THEN
+            IF( SNAME ) THEN
+               NB = 64
+            ELSE
+               NB = 64
+            END IF
+         END IF
+      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
+         IF( C3.EQ.'EBZ' ) THEN
+            NB = 1
+         END IF
+      END IF
+      ILAENV = NB
+      RETURN
+*
+   60 CONTINUE
+*
+*     ISPEC = 2:  minimum block size
+*
+      NBMIN = 2
+      IF( C2.EQ.'GE' ) THEN
+         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+     $       'QLF' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 2
+            ELSE
+               NBMIN = 2
+            END IF
+         ELSE IF( C3.EQ.'HRD' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 2
+            ELSE
+               NBMIN = 2
+            END IF
+         ELSE IF( C3.EQ.'BRD' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 2
+            ELSE
+               NBMIN = 2
+            END IF
+         ELSE IF( C3.EQ.'TRI' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 2
+            ELSE
+               NBMIN = 2
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'SY' ) THEN
+         IF( C3.EQ.'TRF' ) THEN
+            IF( SNAME ) THEN
+               NBMIN = 8
+            ELSE
+               NBMIN = 8
+            END IF
+         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+            NBMIN = 2
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+         IF( C3.EQ.'TRD' ) THEN
+            NBMIN = 2
+         END IF
+      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NBMIN = 2
+            END IF
+         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NBMIN = 2
+            END IF
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NBMIN = 2
+            END IF
+         ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NBMIN = 2
+            END IF
+         END IF
+      END IF
+      ILAENV = NBMIN
+      RETURN
+*
+   70 CONTINUE
+*
+*     ISPEC = 3:  crossover point
+*
+      NX = 0
+      IF( C2.EQ.'GE' ) THEN
+         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+     $       'QLF' ) THEN
+            IF( SNAME ) THEN
+               NX = 128
+            ELSE
+               NX = 128
+            END IF
+         ELSE IF( C3.EQ.'HRD' ) THEN
+            IF( SNAME ) THEN
+               NX = 128
+            ELSE
+               NX = 128
+            END IF
+         ELSE IF( C3.EQ.'BRD' ) THEN
+            IF( SNAME ) THEN
+               NX = 128
+            ELSE
+               NX = 128
+            END IF
+         END IF
+      ELSE IF( C2.EQ.'SY' ) THEN
+         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+            NX = 32
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+         IF( C3.EQ.'TRD' ) THEN
+            NX = 32
+         END IF
+      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NX = 128
+            END IF
+         END IF
+      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+         IF( C3( 1: 1 ).EQ.'G' ) THEN
+            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+     $          'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+     $           THEN
+               NX = 128
+            END IF
+         END IF
+      END IF
+      ILAENV = NX
+      RETURN
+*
+   80 CONTINUE
+*
+*     ISPEC = 4:  number of shifts (used by xHSEQR)
+*
+      ILAENV = 6
+      RETURN
+*
+   90 CONTINUE
+*
+*     ISPEC = 5:  minimum column dimension (not used)
+*
+      ILAENV = 2
+      RETURN
+*
+  100 CONTINUE
+*
+*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
+*
+      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
+      RETURN
+*
+  110 CONTINUE
+*
+*     ISPEC = 7:  number of processors (not used)
+*
+      ILAENV = 1
+      RETURN
+*
+  120 CONTINUE
+*
+*     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
+*
+      ILAENV = 50
+      RETURN
+*
+  130 CONTINUE
+*
+*     ISPEC = 9:  maximum size of the subproblems at the bottom of the
+*                 computation tree in the divide-and-conquer algorithm
+*                 (used by xGELSD and xGESDD)
+*
+      ILAENV = 25
+      RETURN
+*
+  140 CONTINUE
+*
+*     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
+*
+*     ILAENV = 0
+      ILAENV = 1
+      IF( ILAENV.EQ.1 ) THEN
+         ILAENV = IEEECK( 0, 0.0, 1.0 )
+      END IF
+      RETURN
+*
+  150 CONTINUE
+*
+*     ISPEC = 11: infinity arithmetic can be trusted not to trap
+*
+*     ILAENV = 0
+      ILAENV = 1
+      IF( ILAENV.EQ.1 ) THEN
+         ILAENV = IEEECK( 1, 0.0, 1.0 )
+      END IF
+      RETURN
+*
+  160 CONTINUE
+*
+*     12 <= ISPEC <= 16: xHSEQR or one of its subroutines. 
+*
+      ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+      RETURN
+*
+*     End of ILAENV
+*
+      END
diff --git a/src/lib/lapack/iparmq.f b/src/lib/lapack/iparmq.f
new file mode 100644
index 00000000..d9d0af36
--- /dev/null
+++ b/src/lib/lapack/iparmq.f
@@ -0,0 +1,253 @@
+      INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*     
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, ISPEC, LWORK, N
+      CHARACTER          NAME*( * ), OPTS*( * )
+*
+*  Purpose
+*  =======
+*
+*       This program sets problem and machine dependent parameters
+*       useful for xHSEQR and its subroutines. It is called whenever 
+*       ILAENV is called with 12 <= ISPEC <= 16
+*
+*  Arguments
+*  =========
+*
+*       ISPEC  (input) integer scalar
+*              ISPEC specifies which tunable parameter IPARMQ should
+*              return.
+*
+*              ISPEC=12: (INMIN)  Matrices of order nmin or less
+*                        are sent directly to xLAHQR, the implicit
+*                        double shift QR algorithm.  NMIN must be
+*                        at least 11.
+*
+*              ISPEC=13: (INWIN)  Size of the deflation window.
+*                        This is best set greater than or equal to
+*                        the number of simultaneous shifts NS.
+*                        Larger matrices benefit from larger deflation
+*                        windows.
+*
+*              ISPEC=14: (INIBL) Determines when to stop nibbling and
+*                        invest in an (expensive) multi-shift QR sweep.
+*                        If the aggressive early deflation subroutine
+*                        finds LD converged eigenvalues from an order
+*                        NW deflation window and LD.GT.(NW*NIBBLE)/100,
+*                        then the next QR sweep is skipped and early
+*                        deflation is applied immediately to the
+*                        remaining active diagonal block.  Setting
+*                        IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
+*                        multi-shift QR sweep whenever early deflation
+*                        finds a converged eigenvalue.  Setting
+*                        IPARMQ(ISPEC=14) greater than or equal to 100
+*                        prevents TTQRE from skipping a multi-shift
+*                        QR sweep.
+*
+*              ISPEC=15: (NSHFTS) The number of simultaneous shifts in
+*                        a multi-shift QR iteration.
+*
+*              ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
+*                        following meanings.
+*                        0:  During the multi-shift QR sweep,
+*                            xLAQR5 does not accumulate reflections and
+*                            does not use matrix-matrix multiply to
+*                            update the far-from-diagonal matrix
+*                            entries.
+*                        1:  During the multi-shift QR sweep,
+*                            xLAQR5 and/or xLAQRaccumulates reflections and uses
+*                            matrix-matrix multiply to update the
+*                            far-from-diagonal matrix entries.
+*                        2:  During the multi-shift QR sweep.
+*                            xLAQR5 accumulates reflections and takes
+*                            advantage of 2-by-2 block structure during
+*                            matrix-matrix multiplies.
+*                        (If xTRMM is slower than xGEMM, then
+*                        IPARMQ(ISPEC=16)=1 may be more efficient than
+*                        IPARMQ(ISPEC=16)=2 despite the greater level of
+*                        arithmetic work implied by the latter choice.)
+*
+*       NAME    (input) character string
+*               Name of the calling subroutine
+*
+*       OPTS    (input) character string
+*               This is a concatenation of the string arguments to
+*               TTQRE.
+*
+*       N       (input) integer scalar
+*               N is the order of the Hessenberg matrix H.
+*
+*       ILO     (input) INTEGER
+*       IHI     (input) INTEGER
+*               It is assumed that H is already upper triangular
+*               in rows and columns 1:ILO-1 and IHI+1:N.
+*
+*       LWORK   (input) integer scalar
+*               The amount of workspace available.
+*
+*  Further Details
+*  ===============
+*
+*       Little is known about how best to choose these parameters.
+*       It is possible to use different values of the parameters
+*       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
+*
+*       It is probably best to choose different parameters for
+*       different matrices and different parameters at different
+*       times during the iteration, but this has not been
+*       implemented --- yet.
+*
+*
+*       The best choices of most of the parameters depend
+*       in an ill-understood way on the relative execution
+*       rate of xLAQR3 and xLAQR5 and on the nature of each
+*       particular eigenvalue problem.  Experiment may be the
+*       only practical way to determine which choices are most
+*       effective.
+*
+*       Following is a list of default values supplied by IPARMQ.
+*       These defaults may be adjusted in order to attain better
+*       performance in any particular computational environment.
+*
+*       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
+*                        Default: 75. (Must be at least 11.)
+*
+*       IPARMQ(ISPEC=13) Recommended deflation window size.
+*                        This depends on ILO, IHI and NS, the
+*                        number of simultaneous shifts returned
+*                        by IPARMQ(ISPEC=15).  The default for
+*                        (IHI-ILO+1).LE.500 is NS.  The default
+*                        for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+*       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14.
+*
+*       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
+*                        a multi-shift QR iteration.
+*
+*                        If IHI-ILO+1 is ...
+*
+*                        greater than      ...but less    ... the
+*                        or equal to ...      than        default is
+*
+*                                0               30       NS =   2+
+*                               30               60       NS =   4+
+*                               60              150       NS =  10
+*                              150              590       NS =  **
+*                              590             3000       NS =  64
+*                             3000             6000       NS = 128
+*                             6000             infinity   NS = 256
+*
+*                    (+)  By default matrices of this order are
+*                         passed to the implicit double shift routine
+*                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These
+*                         values of NS are used only in case of a rare
+*                         xLAHQR failure.
+*
+*                    (**) The asterisks (**) indicate an ad-hoc
+*                         function increasing from 10 to 64.
+*
+*       IPARMQ(ISPEC=16) Select structured matrix multiply.
+*                        (See ISPEC=16 above for details.)
+*                        Default: 3.
+*
+*     ================================================================
+*     .. Parameters ..
+      INTEGER            INMIN, INWIN, INIBL, ISHFTS, IACC22
+      PARAMETER          ( INMIN = 12, INWIN = 13, INIBL = 14,
+     $                   ISHFTS = 15, IACC22 = 16 )
+      INTEGER            NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
+      PARAMETER          ( NMIN = 75, K22MIN = 14, KACMIN = 14,
+     $                   NIBBLE = 14, KNWSWP = 500 )
+      REAL               TWO
+      PARAMETER          ( TWO = 2.0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            NH, NS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          LOG, MAX, MOD, NINT, REAL
+*     ..
+*     .. Executable Statements ..
+      IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
+     $    ( ISPEC.EQ.IACC22 ) ) THEN
+*
+*        ==== Set the number simultaneous shifts ====
+*
+         NH = IHI - ILO + 1
+         NS = 2
+         IF( NH.GE.30 )
+     $      NS = 4
+         IF( NH.GE.60 )
+     $      NS = 10
+         IF( NH.GE.150 )
+     $      NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
+         IF( NH.GE.590 )
+     $      NS = 64
+         IF( NH.GE.3000 )
+     $      NS = 128
+         IF( NH.GE.6000 )
+     $      NS = 256
+         NS = MAX( 2, NS-MOD( NS, 2 ) )
+      END IF
+*
+      IF( ISPEC.EQ.INMIN ) THEN
+*
+*
+*        ===== Matrices of order smaller than NMIN get sent
+*        .     to xLAHQR, the classic double shift algorithm.
+*        .     This must be at least 11. ====
+*
+         IPARMQ = NMIN
+*
+      ELSE IF( ISPEC.EQ.INIBL ) THEN
+*
+*        ==== INIBL: skip a multi-shift qr iteration and
+*        .    whenever aggressive early deflation finds
+*        .    at least (NIBBLE*(window size)/100) deflations. ====
+*
+         IPARMQ = NIBBLE
+*
+      ELSE IF( ISPEC.EQ.ISHFTS ) THEN
+*
+*        ==== NSHFTS: The number of simultaneous shifts =====
+*
+         IPARMQ = NS
+*
+      ELSE IF( ISPEC.EQ.INWIN ) THEN
+*
+*        ==== NW: deflation window size.  ====
+*
+         IF( NH.LE.KNWSWP ) THEN
+            IPARMQ = NS
+         ELSE
+            IPARMQ = 3*NS / 2
+         END IF
+*
+      ELSE IF( ISPEC.EQ.IACC22 ) THEN
+*
+*        ==== IACC22: Whether to accumulate reflections
+*        .     before updating the far-from-diagonal elements
+*        .     and whether to use 2-by-2 block structure while
+*        .     doing it.  A small amount of work could be saved
+*        .     by making this choice dependent also upon the
+*        .     NH=IHI-ILO+1.
+*
+         IPARMQ = 0
+         IF( NS.GE.KACMIN )
+     $      IPARMQ = 1
+         IF( NS.GE.K22MIN )
+     $      IPARMQ = 2
+*
+      ELSE
+*        ===== invalid value of ispec =====
+         IPARMQ = -1
+*
+      END IF
+*
+*     ==== End of IPARMQ ====
+*
+      END
diff --git a/src/lib/lapack/izmax1.f b/src/lib/lapack/izmax1.f
new file mode 100644
index 00000000..7ebffee3
--- /dev/null
+++ b/src/lib/lapack/izmax1.f
@@ -0,0 +1,95 @@
+      INTEGER          FUNCTION IZMAX1( N, CX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  IZMAX1 finds the index of the element whose real part has maximum
+*  absolute value.
+*
+*  Based on IZAMAX from Level 1 BLAS.
+*  The change is to use the 'genuine' absolute value.
+*
+*  Contributed by Nick Higham for use with ZLACON.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vector CX.
+*
+*  CX      (input) COMPLEX*16 array, dimension (N)
+*          The vector whose elements will be summed.
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive values of CX.  INCX >= 1.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX
+      DOUBLE PRECISION   SMAX
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+*
+*     NEXT LINE IS THE ONLY MODIFICATION.
+      CABS1( ZDUM ) = ABS( ZDUM )
+*     ..
+*     .. Executable Statements ..
+*
+      IZMAX1 = 0
+      IF( N.LT.1 )
+     $   RETURN
+      IZMAX1 = 1
+      IF( N.EQ.1 )
+     $   RETURN
+      IF( INCX.EQ.1 )
+     $   GO TO 30
+*
+*     CODE FOR INCREMENT NOT EQUAL TO 1
+*
+      IX = 1
+      SMAX = CABS1( CX( 1 ) )
+      IX = IX + INCX
+      DO 20 I = 2, N
+         IF( CABS1( CX( IX ) ).LE.SMAX )
+     $      GO TO 10
+         IZMAX1 = I
+         SMAX = CABS1( CX( IX ) )
+   10    CONTINUE
+         IX = IX + INCX
+   20 CONTINUE
+      RETURN
+*
+*     CODE FOR INCREMENT EQUAL TO 1
+*
+   30 CONTINUE
+      SMAX = CABS1( CX( 1 ) )
+      DO 40 I = 2, N
+         IF( CABS1( CX( I ) ).LE.SMAX )
+     $      GO TO 40
+         IZMAX1 = I
+         SMAX = CABS1( CX( I ) )
+   40 CONTINUE
+      RETURN
+*
+*     End of IZMAX1
+*
+      END
diff --git a/src/lib/lapack/lsame.f b/src/lib/lapack/lsame.f
new file mode 100644
index 00000000..bf25d86f
--- /dev/null
+++ b/src/lib/lapack/lsame.f
@@ -0,0 +1,87 @@
+      LOGICAL          FUNCTION LSAME( CA, CB )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     September 30, 1994
+*
+*     .. Scalar Arguments ..
+      CHARACTER          CA, CB
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
+*  case.
+*
+*  Arguments
+*  =========
+*
+*  CA      (input) CHARACTER*1
+*  CB      (input) CHARACTER*1
+*          CA and CB specify the single characters to be compared.
+*
+* =====================================================================
+*
+*     .. Intrinsic Functions ..
+      INTRINSIC          ICHAR
+*     ..
+*     .. Local Scalars ..
+      INTEGER            INTA, INTB, ZCODE
+*     ..
+*     .. Executable Statements ..
+*
+*     Test if the characters are equal
+*
+      LSAME = CA.EQ.CB
+      IF( LSAME )
+     $   RETURN
+*
+*     Now test for equivalence if both characters are alphabetic.
+*
+      ZCODE = ICHAR( 'Z' )
+*
+*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
+*     machines, on which ICHAR returns a value with bit 8 set.
+*     ICHAR('A') on Prime machines returns 193 which is the same as
+*     ICHAR('A') on an EBCDIC machine.
+*
+      INTA = ICHAR( CA )
+      INTB = ICHAR( CB )
+*
+      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
+*
+*        ASCII is assumed - ZCODE is the ASCII code of either lower or
+*        upper case 'Z'.
+*
+         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
+         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
+*
+      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
+*
+*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
+*        upper case 'Z'.
+*
+         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
+     $       INTA.GE.145 .AND. INTA.LE.153 .OR.
+     $       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
+         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
+     $       INTB.GE.145 .AND. INTB.LE.153 .OR.
+     $       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
+*
+      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
+*
+*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
+*        plus 128 of either lower or upper case 'Z'.
+*
+         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
+         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
+      END IF
+      LSAME = INTA.EQ.INTB
+*
+*     RETURN
+*
+*     End of LSAME
+*
+      END
diff --git a/src/lib/lapack/slamch.f b/src/lib/lapack/slamch.f
new file mode 100644
index 00000000..afb4d368
--- /dev/null
+++ b/src/lib/lapack/slamch.f
@@ -0,0 +1,857 @@
+      REAL             FUNCTION SLAMCH( CMACH )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992 
+*
+*     .. Scalar Arguments ..
+      CHARACTER          CMACH
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMCH determines single precision machine parameters.
+*
+*  Arguments
+*  =========
+*
+*  CMACH   (input) CHARACTER*1
+*          Specifies the value to be returned by SLAMCH:
+*          = 'E' or 'e',   SLAMCH := eps
+*          = 'S' or 's ,   SLAMCH := sfmin
+*          = 'B' or 'b',   SLAMCH := base
+*          = 'P' or 'p',   SLAMCH := eps*base
+*          = 'N' or 'n',   SLAMCH := t
+*          = 'R' or 'r',   SLAMCH := rnd
+*          = 'M' or 'm',   SLAMCH := emin
+*          = 'U' or 'u',   SLAMCH := rmin
+*          = 'L' or 'l',   SLAMCH := emax
+*          = 'O' or 'o',   SLAMCH := rmax
+*
+*          where
+*
+*          eps   = relative machine precision
+*          sfmin = safe minimum, such that 1/sfmin does not overflow
+*          base  = base of the machine
+*          prec  = eps*base
+*          t     = number of (base) digits in the mantissa
+*          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
+*          emin  = minimum exponent before (gradual) underflow
+*          rmin  = underflow threshold - base**(emin-1)
+*          emax  = largest exponent before overflow
+*          rmax  = overflow threshold  - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ONE, ZERO
+      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LRND
+      INTEGER            BETA, IMAX, IMIN, IT
+      REAL               BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+     $                   RND, SFMIN, SMALL, T
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAMC2
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+     $                   EMAX, RMAX, PREC
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+         BASE = BETA
+         T = IT
+         IF( LRND ) THEN
+            RND = ONE
+            EPS = ( BASE**( 1-IT ) ) / 2
+         ELSE
+            RND = ZERO
+            EPS = BASE**( 1-IT )
+         END IF
+         PREC = EPS*BASE
+         EMIN = IMIN
+         EMAX = IMAX
+         SFMIN = RMIN
+         SMALL = ONE / RMAX
+         IF( SMALL.GE.SFMIN ) THEN
+*
+*           Use SMALL plus a bit, to avoid the possibility of rounding
+*           causing overflow when computing  1/sfmin.
+*
+            SFMIN = SMALL*( ONE+EPS )
+         END IF
+      END IF
+*
+      IF( LSAME( CMACH, 'E' ) ) THEN
+         RMACH = EPS
+      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+         RMACH = SFMIN
+      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+         RMACH = BASE
+      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+         RMACH = PREC
+      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+         RMACH = T
+      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+         RMACH = RND
+      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+         RMACH = EMIN
+      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+         RMACH = RMIN
+      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+         RMACH = EMAX
+      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+         RMACH = RMAX
+      END IF
+*
+      SLAMCH = RMACH
+      RETURN
+*
+*     End of SLAMCH
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE1, RND
+      INTEGER            BETA, T
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMC1 determines the machine parameters given by BETA, T, RND, and
+*  IEEE1.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  IEEE1   (output) LOGICAL
+*          Specifies whether rounding appears to be done in the IEEE
+*          'round to nearest' style.
+*
+*  Further Details
+*  ===============
+*
+*  The routine is based on the routine  ENVRON  by Malcolm and
+*  incorporates suggestions by Gentleman and Marovich. See
+*
+*     Malcolm M. A. (1972) Algorithms to reveal properties of
+*        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+*     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+*        that reveal properties of floating point arithmetic units.
+*        Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, LIEEE1, LRND
+      INTEGER            LBETA, LT
+      REAL               A, B, C, F, ONE, QTR, SAVEC, T1, T2
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3
+      EXTERNAL           SLAMC3
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ONE = 1
+*
+*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
+*        IEEE1, T and RND.
+*
+*        Throughout this routine  we use the function  SLAMC3  to ensure
+*        that relevant values are  stored and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        Compute  a = 2.0**m  with the  smallest positive integer m such
+*        that
+*
+*           fl( a + 1.0 ) = a.
+*
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   10    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            A = 2*A
+            C = SLAMC3( A, ONE )
+            C = SLAMC3( C, -A )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+*        Now compute  b = 2.0**m  with the smallest positive integer m
+*        such that
+*
+*           fl( a + b ) .gt. a.
+*
+         B = 1
+         C = SLAMC3( A, B )
+*
+*+       WHILE( C.EQ.A )LOOP
+   20    CONTINUE
+         IF( C.EQ.A ) THEN
+            B = 2*B
+            C = SLAMC3( A, B )
+            GO TO 20
+         END IF
+*+       END WHILE
+*
+*        Now compute the base.  a and c  are neighbouring floating point
+*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
+*        their difference is beta. Adding 0.25 to c is to ensure that it
+*        is truncated to beta and not ( beta - 1 ).
+*
+         QTR = ONE / 4
+         SAVEC = C
+         C = SLAMC3( C, -A )
+         LBETA = C + QTR
+*
+*        Now determine whether rounding or chopping occurs,  by adding a
+*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
+*
+         B = LBETA
+         F = SLAMC3( B / 2, -B / 100 )
+         C = SLAMC3( F, A )
+         IF( C.EQ.A ) THEN
+            LRND = .TRUE.
+         ELSE
+            LRND = .FALSE.
+         END IF
+         F = SLAMC3( B / 2, B / 100 )
+         C = SLAMC3( F, A )
+         IF( ( LRND ) .AND. ( C.EQ.A ) )
+     $      LRND = .FALSE.
+*
+*        Try and decide whether rounding is done in the  IEEE  'round to
+*        nearest' style. B/2 is half a unit in the last place of the two
+*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
+*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
+*        A, but adding B/2 to SAVEC should change SAVEC.
+*
+         T1 = SLAMC3( B / 2, A )
+         T2 = SLAMC3( B / 2, SAVEC )
+         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+*        Now find  the  mantissa, t.  It should  be the  integer part of
+*        log to the base beta of a,  however it is safer to determine  t
+*        by powering.  So we find t as the smallest positive integer for
+*        which
+*
+*           fl( beta**t + 1.0 ) = 1.0.
+*
+         LT = 0
+         A = 1
+         C = 1
+*
+*+       WHILE( C.EQ.ONE )LOOP
+   30    CONTINUE
+         IF( C.EQ.ONE ) THEN
+            LT = LT + 1
+            A = A*LBETA
+            C = SLAMC3( A, ONE )
+            C = SLAMC3( C, -A )
+            GO TO 30
+         END IF
+*+       END WHILE
+*
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      IEEE1 = LIEEE1
+      RETURN
+*
+*     End of SLAMC1
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            RND
+      INTEGER            BETA, EMAX, EMIN, T
+      REAL               EPS, RMAX, RMIN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMC2 determines the machine parameters specified in its argument
+*  list.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (output) INTEGER
+*          The base of the machine.
+*
+*  T       (output) INTEGER
+*          The number of ( BETA ) digits in the mantissa.
+*
+*  RND     (output) LOGICAL
+*          Specifies whether proper rounding  ( RND = .TRUE. )  or
+*          chopping  ( RND = .FALSE. )  occurs in addition. This may not
+*          be a reliable guide to the way in which the machine performs
+*          its arithmetic.
+*
+*  EPS     (output) REAL
+*          The smallest positive number such that
+*
+*             fl( 1.0 - EPS ) .LT. 1.0,
+*
+*          where fl denotes the computed value.
+*
+*  EMIN    (output) INTEGER
+*          The minimum exponent before (gradual) underflow occurs.
+*
+*  RMIN    (output) REAL
+*          The smallest normalized number for the machine, given by
+*          BASE**( EMIN - 1 ), where  BASE  is the floating point value
+*          of BETA.
+*
+*  EMAX    (output) INTEGER
+*          The maximum exponent before overflow occurs.
+*
+*  RMAX    (output) REAL
+*          The largest positive number for the machine, given by
+*          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
+*          value of BETA.
+*
+*  Further Details
+*  ===============
+*
+*  The computation of  EPS  is based on a routine PARANOIA by
+*  W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
+      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+     $                   NGNMIN, NGPMIN
+      REAL               A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+     $                   SIXTH, SMALL, THIRD, TWO, ZERO
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3
+      EXTERNAL           SLAMC3
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           SLAMC1, SLAMC4, SLAMC5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. Save statement ..
+      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+     $                   LRMIN, LT
+*     ..
+*     .. Data statements ..
+      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
+*     ..
+*     .. Executable Statements ..
+*
+      IF( FIRST ) THEN
+         FIRST = .FALSE.
+         ZERO = 0
+         ONE = 1
+         TWO = 2
+*
+*        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
+*        BETA, T, RND, EPS, EMIN and RMIN.
+*
+*        Throughout this routine  we use the function  SLAMC3  to ensure
+*        that relevant values are stored  and not held in registers,  or
+*        are not affected by optimizers.
+*
+*        SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
+*
+         CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+*        Start to find EPS.
+*
+         B = LBETA
+         A = B**( -LT )
+         LEPS = A
+*
+*        Try some tricks to see whether or not this is the correct  EPS.
+*
+         B = TWO / 3
+         HALF = ONE / 2
+         SIXTH = SLAMC3( B, -HALF )
+         THIRD = SLAMC3( SIXTH, SIXTH )
+         B = SLAMC3( THIRD, -HALF )
+         B = SLAMC3( B, SIXTH )
+         B = ABS( B )
+         IF( B.LT.LEPS )
+     $      B = LEPS
+*
+         LEPS = 1
+*
+*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+   10    CONTINUE
+         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+            LEPS = B
+            C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+            C = SLAMC3( HALF, -C )
+            B = SLAMC3( HALF, C )
+            C = SLAMC3( HALF, -B )
+            B = SLAMC3( HALF, C )
+            GO TO 10
+         END IF
+*+       END WHILE
+*
+         IF( A.LT.LEPS )
+     $      LEPS = A
+*
+*        Computation of EPS complete.
+*
+*        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
+*        Keep dividing  A by BETA until (gradual) underflow occurs. This
+*        is detected when we cannot recover the previous A.
+*
+         RBASE = ONE / LBETA
+         SMALL = ONE
+         DO 20 I = 1, 3
+            SMALL = SLAMC3( SMALL*RBASE, ZERO )
+   20    CONTINUE
+         A = SLAMC3( ONE, SMALL )
+         CALL SLAMC4( NGPMIN, ONE, LBETA )
+         CALL SLAMC4( NGNMIN, -ONE, LBETA )
+         CALL SLAMC4( GPMIN, A, LBETA )
+         CALL SLAMC4( GNMIN, -A, LBETA )
+         IEEE = .FALSE.
+*
+         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( NGPMIN.EQ.GPMIN ) THEN
+               LEMIN = NGPMIN
+*            ( Non twos-complement machines, no gradual underflow;
+*              e.g.,  VAX )
+            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+               LEMIN = NGPMIN - 1 + LT
+               IEEE = .TRUE.
+*            ( Non twos-complement machines, with gradual underflow;
+*              e.g., IEEE standard followers )
+            ELSE
+               LEMIN = MIN( NGPMIN, GPMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN )
+*            ( Twos-complement machines, no gradual underflow;
+*              e.g., CYBER 205 )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+     $            ( GPMIN.EQ.GNMIN ) ) THEN
+            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+*            ( Twos-complement machines with gradual underflow;
+*              no known machine )
+            ELSE
+               LEMIN = MIN( NGPMIN, NGNMIN )
+*            ( A guess; no known machine )
+               IWARN = .TRUE.
+            END IF
+*
+         ELSE
+            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+*         ( A guess; no known machine )
+            IWARN = .TRUE.
+         END IF
+***
+* Comment out this if block if EMIN is ok
+         IF( IWARN ) THEN
+            FIRST = .TRUE.
+            WRITE( 6, FMT = 9999 )LEMIN
+         END IF
+***
+*
+*        Assume IEEE arithmetic if we found denormalised  numbers above,
+*        or if arithmetic seems to round in the  IEEE style,  determined
+*        in routine SLAMC1. A true IEEE machine should have both  things
+*        true; however, faulty machines may have one or the other.
+*
+         IEEE = IEEE .OR. LIEEE1
+*
+*        Compute  RMIN by successive division by  BETA. We could compute
+*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
+*        this computation.
+*
+         LRMIN = 1
+         DO 30 I = 1, 1 - LEMIN
+            LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
+   30    CONTINUE
+*
+*        Finally, call SLAMC5 to compute EMAX and RMAX.
+*
+         CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+      END IF
+*
+      BETA = LBETA
+      T = LT
+      RND = LRND
+      EPS = LEPS
+      EMIN = LEMIN
+      RMIN = LRMIN
+      EMAX = LEMAX
+      RMAX = LRMAX
+*
+      RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+     $      '  EMIN = ', I8, /
+     $      ' If, after inspection, the value EMIN looks',
+     $      ' acceptable please comment out ',
+     $      / ' the IF block as marked within the code of routine',
+     $      ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+*     End of SLAMC2
+*
+      END
+*
+************************************************************************
+*
+      REAL             FUNCTION SLAMC3( A, B )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      REAL               A, B
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMC3  is intended to force  A  and  B  to be stored prior to doing
+*  the addition of  A  and  B ,  for use in situations where optimizers
+*  might hold one of these in a register.
+*
+*  Arguments
+*  =========
+*
+*  A, B    (input) REAL
+*          The values A and B.
+*
+* =====================================================================
+*
+*     .. Executable Statements ..
+*
+      SLAMC3 = A + B
+*
+      RETURN
+*
+*     End of SLAMC3
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE SLAMC4( EMIN, START, BASE )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      INTEGER            BASE, EMIN
+      REAL               START
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMC4 is a service routine for SLAMC2.
+*
+*  Arguments
+*  =========
+*
+*  EMIN    (output) EMIN
+*          The minimum exponent before (gradual) underflow, computed by
+*          setting A = START and dividing by BASE until the previous A
+*          can not be recovered.
+*
+*  START   (input) REAL
+*          The starting point for determining EMIN.
+*
+*  BASE    (input) INTEGER
+*          The base of the machine.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I
+      REAL               A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3
+      EXTERNAL           SLAMC3
+*     ..
+*     .. Executable Statements ..
+*
+      A = START
+      ONE = 1
+      RBASE = ONE / BASE
+      ZERO = 0
+      EMIN = 1
+      B1 = SLAMC3( A*RBASE, ZERO )
+      C1 = A
+      C2 = A
+      D1 = A
+      D2 = A
+*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
+   10 CONTINUE
+      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+     $    ( D2.EQ.A ) ) THEN
+         EMIN = EMIN - 1
+         A = B1
+         B1 = SLAMC3( A / BASE, ZERO )
+         C1 = SLAMC3( B1*BASE, ZERO )
+         D1 = ZERO
+         DO 20 I = 1, BASE
+            D1 = D1 + B1
+   20    CONTINUE
+         B2 = SLAMC3( A*RBASE, ZERO )
+         C2 = SLAMC3( B2 / RBASE, ZERO )
+         D2 = ZERO
+         DO 30 I = 1, BASE
+            D2 = D2 + B2
+   30    CONTINUE
+         GO TO 10
+      END IF
+*+    END WHILE
+*
+      RETURN
+*
+*     End of SLAMC4
+*
+      END
+*
+************************************************************************
+*
+      SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+*  -- LAPACK auxiliary routine (version 3.0) --
+*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+*     Courant Institute, Argonne National Lab, and Rice University
+*     October 31, 1992
+*
+*     .. Scalar Arguments ..
+      LOGICAL            IEEE
+      INTEGER            BETA, EMAX, EMIN, P
+      REAL               RMAX
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  SLAMC5 attempts to compute RMAX, the largest machine floating-point
+*  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
+*  approximately to a power of 2.  It will fail on machines where this
+*  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+*  EMAX = 28718).  It will also fail if the value supplied for EMIN is
+*  too large (i.e. too close to zero), probably with overflow.
+*
+*  Arguments
+*  =========
+*
+*  BETA    (input) INTEGER
+*          The base of floating-point arithmetic.
+*
+*  P       (input) INTEGER
+*          The number of base BETA digits in the mantissa of a
+*          floating-point value.
+*
+*  EMIN    (input) INTEGER
+*          The minimum exponent before (gradual) underflow.
+*
+*  IEEE    (input) LOGICAL
+*          A logical flag specifying whether or not the arithmetic
+*          system is thought to comply with the IEEE standard.
+*
+*  EMAX    (output) INTEGER
+*          The largest exponent before overflow
+*
+*  RMAX    (output) REAL
+*          The largest machine floating-point number.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      REAL               ZERO, ONE
+      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+      REAL               OLDY, RECBAS, Y, Z
+*     ..
+*     .. External Functions ..
+      REAL               SLAMC3
+      EXTERNAL           SLAMC3
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MOD
+*     ..
+*     .. Executable Statements ..
+*
+*     First compute LEXP and UEXP, two powers of 2 that bound
+*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+*     approximately to the bound that is closest to abs(EMIN).
+*     (EMAX is the exponent of the required number RMAX).
+*
+      LEXP = 1
+      EXBITS = 1
+   10 CONTINUE
+      TRY = LEXP*2
+      IF( TRY.LE.( -EMIN ) ) THEN
+         LEXP = TRY
+         EXBITS = EXBITS + 1
+         GO TO 10
+      END IF
+      IF( LEXP.EQ.-EMIN ) THEN
+         UEXP = LEXP
+      ELSE
+         UEXP = TRY
+         EXBITS = EXBITS + 1
+      END IF
+*
+*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+*     than or equal to EMIN. EXBITS is the number of bits needed to
+*     store the exponent.
+*
+      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+         EXPSUM = 2*LEXP
+      ELSE
+         EXPSUM = 2*UEXP
+      END IF
+*
+*     EXPSUM is the exponent range, approximately equal to
+*     EMAX - EMIN + 1 .
+*
+      EMAX = EXPSUM + EMIN - 1
+      NBITS = 1 + EXBITS + P
+*
+*     NBITS is the total number of bits needed to store a
+*     floating-point number.
+*
+      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+*        Either there are an odd number of bits used to store a
+*        floating-point number, which is unlikely, or some bits are
+*        not used in the representation of numbers, which is possible,
+*        (e.g. Cray machines) or the mantissa has an implicit bit,
+*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+*        most likely. We have to assume the last alternative.
+*        If this is true, then we need to reduce EMAX by one because
+*        there must be some way of representing zero in an implicit-bit
+*        system. On machines like Cray, we are reducing EMAX by one
+*        unnecessarily.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+      IF( IEEE ) THEN
+*
+*        Assume we are on an IEEE machine which reserves one exponent
+*        for infinity and NaN.
+*
+         EMAX = EMAX - 1
+      END IF
+*
+*     Now create RMAX, the largest machine number, which should
+*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+*     First compute 1.0 - BETA**(-P), being careful that the
+*     result is less than 1.0 .
+*
+      RECBAS = ONE / BETA
+      Z = BETA - ONE
+      Y = ZERO
+      DO 20 I = 1, P
+         Z = Z*RECBAS
+         IF( Y.LT.ONE )
+     $      OLDY = Y
+         Y = SLAMC3( Y, Z )
+   20 CONTINUE
+      IF( Y.GE.ONE )
+     $   Y = OLDY
+*
+*     Now multiply by BETA**EMAX to get RMAX.
+*
+      DO 30 I = 1, EMAX
+         Y = SLAMC3( Y*BETA, ZERO )
+   30 CONTINUE
+*
+      RMAX = Y
+      RETURN
+*
+*     End of SLAMC5
+*
+      END
diff --git a/src/lib/lapack/xerbla.f b/src/lib/lapack/xerbla.f
new file mode 100644
index 00000000..c8c9231b
--- /dev/null
+++ b/src/lib/lapack/xerbla.f
@@ -0,0 +1,45 @@
+      SUBROUTINE XERBLA( SRNAME, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER*6        SRNAME
+      INTEGER            INFO
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  XERBLA  is an error handler for the LAPACK routines.
+*  It is called by an LAPACK routine if an input parameter has an
+*  invalid value.  A message is printed and execution stops.
+*
+*  Installers may consider modifying the STOP statement in order to
+*  call system-specific exception-handling facilities.
+*
+*  Arguments
+*  =========
+*
+*  SRNAME  (input) CHARACTER*6
+*          The name of the routine which called XERBLA.
+*
+*  INFO    (input) INTEGER
+*          The position of the invalid parameter in the parameter list
+*          of the calling routine.
+*
+* =====================================================================
+*
+*     .. Executable Statements ..
+*
+      WRITE( *, FMT = 9999 )SRNAME, INFO
+*
+      STOP
+*
+ 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
+     $      'an illegal value' )
+*
+*     End of XERBLA
+*
+      END
diff --git a/src/lib/lapack/zbdsqr.f b/src/lib/lapack/zbdsqr.f
new file mode 100644
index 00000000..f9086be5
--- /dev/null
+++ b/src/lib/lapack/zbdsqr.f
@@ -0,0 +1,742 @@
+      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+     $                   LDU, C, LDC, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), RWORK( * )
+      COMPLEX*16         C( LDC, * ), U( LDU, * ), VT( LDVT, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZBDSQR computes the singular values and, optionally, the right and/or
+*  left singular vectors from the singular value decomposition (SVD) of
+*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
+*  zero-shift QR algorithm.  The SVD of B has the form
+* 
+*     B = Q * S * P**H
+* 
+*  where S is the diagonal matrix of singular values, Q is an orthogonal
+*  matrix of left singular vectors, and P is an orthogonal matrix of
+*  right singular vectors.  If left singular vectors are requested, this
+*  subroutine actually returns U*Q instead of Q, and, if right singular
+*  vectors are requested, this subroutine returns P**H*VT instead of
+*  P**H, for given complex input matrices U and VT.  When U and VT are
+*  the unitary matrices that reduce a general matrix A to bidiagonal
+*  form: A = U*B*VT, as computed by ZGEBRD, then
+* 
+*     A = (U*Q) * S * (P**H*VT)
+* 
+*  is the SVD of A.  Optionally, the subroutine may also compute Q**H*C
+*  for a given complex input matrix C.
+*
+*  See "Computing  Small Singular Values of Bidiagonal Matrices With
+*  Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
+*  no. 5, pp. 873-912, Sept 1990) and
+*  "Accurate singular values and differential qd algorithms," by
+*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
+*  Department, University of California at Berkeley, July 1992
+*  for a detailed description of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  B is upper bidiagonal;
+*          = 'L':  B is lower bidiagonal.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B.  N >= 0.
+*
+*  NCVT    (input) INTEGER
+*          The number of columns of the matrix VT. NCVT >= 0.
+*
+*  NRU     (input) INTEGER
+*          The number of rows of the matrix U. NRU >= 0.
+*
+*  NCC     (input) INTEGER
+*          The number of columns of the matrix C. NCC >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the n diagonal elements of the bidiagonal matrix B.
+*          On exit, if INFO=0, the singular values of B in decreasing
+*          order.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the N-1 offdiagonal elements of the bidiagonal
+*          matrix B.
+*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
+*          will contain the diagonal and superdiagonal elements of a
+*          bidiagonal matrix orthogonally equivalent to the one given
+*          as input.
+*
+*  VT      (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
+*          On entry, an N-by-NCVT matrix VT.
+*          On exit, VT is overwritten by P**H * VT.
+*          Not referenced if NCVT = 0.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.
+*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
+*
+*  U       (input/output) COMPLEX*16 array, dimension (LDU, N)
+*          On entry, an NRU-by-N matrix U.
+*          On exit, U is overwritten by U * Q.
+*          Not referenced if NRU = 0.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= max(1,NRU).
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC, NCC)
+*          On entry, an N-by-NCC matrix C.
+*          On exit, C is overwritten by Q**H * C.
+*          Not referenced if NCC = 0.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C.
+*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*          if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  If INFO = -i, the i-th argument had an illegal value
+*          > 0:  the algorithm did not converge; D and E contain the
+*                elements of a bidiagonal matrix which is orthogonally
+*                similar to the input matrix B;  if INFO = i, i
+*                elements of E have not converged to zero.
+*
+*  Internal Parameters
+*  ===================
+*
+*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
+*          TOLMUL controls the convergence criterion of the QR loop.
+*          If it is positive, TOLMUL*EPS is the desired relative
+*             precision in the computed singular values.
+*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the
+*             desired absolute accuracy in the computed singular
+*             values (corresponds to relative accuracy
+*             abs(TOLMUL*EPS) in the largest singular value.
+*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably
+*             between 10 (for fast convergence) and .1/EPS
+*             (for there to be some accuracy in the results).
+*          Default is to lose at either one eighth or 2 of the
+*             available decimal digits in each computed singular value
+*             (whichever is smaller).
+*
+*  MAXITR  INTEGER, default = 6
+*          MAXITR controls the maximum number of passes of the
+*          algorithm through its inner loop. The algorithms stops
+*          (and so fails to converge) if the number of passes
+*          through the inner loop exceeds MAXITR*N**2.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D0 )
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D0 )
+      DOUBLE PRECISION   NEGONE
+      PARAMETER          ( NEGONE = -1.0D0 )
+      DOUBLE PRECISION   HNDRTH
+      PARAMETER          ( HNDRTH = 0.01D0 )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 10.0D0 )
+      DOUBLE PRECISION   HNDRD
+      PARAMETER          ( HNDRD = 100.0D0 )
+      DOUBLE PRECISION   MEIGTH
+      PARAMETER          ( MEIGTH = -0.125D0 )
+      INTEGER            MAXITR
+      PARAMETER          ( MAXITR = 6 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, ROTATE
+      INTEGER            I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
+     $                   NM12, NM13, OLDLL, OLDM
+      DOUBLE PRECISION   ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
+     $                   OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
+     $                   SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
+     $                   SN, THRESH, TOL, TOLMUL, UNFL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLARTG, DLAS2, DLASQ1, DLASV2, XERBLA, ZDROT,
+     $                   ZDSCAL, ZLASR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      LOWER = LSAME( UPLO, 'L' )
+      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NCVT.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( NRU.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( NCC.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+     $         ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+         INFO = -9
+      ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+         INFO = -11
+      ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+     $         ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZBDSQR', -INFO )
+         RETURN
+      END IF
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( N.EQ.1 )
+     $   GO TO 160
+*
+*     ROTATE is true if any singular vectors desired, false otherwise
+*
+      ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+*
+*     If no singular vectors desired, use qd algorithm
+*
+      IF( .NOT.ROTATE ) THEN
+         CALL DLASQ1( N, D, E, RWORK, INFO )
+         RETURN
+      END IF
+*
+      NM1 = N - 1
+      NM12 = NM1 + NM1
+      NM13 = NM12 + NM1
+      IDIR = 0
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'Epsilon' )
+      UNFL = DLAMCH( 'Safe minimum' )
+*
+*     If matrix lower bidiagonal, rotate to be upper bidiagonal
+*     by applying Givens rotations on the left
+*
+      IF( LOWER ) THEN
+         DO 10 I = 1, N - 1
+            CALL DLARTG( D( I ), E( I ), CS, SN, R )
+            D( I ) = R
+            E( I ) = SN*D( I+1 )
+            D( I+1 ) = CS*D( I+1 )
+            RWORK( I ) = CS
+            RWORK( NM1+I ) = SN
+   10    CONTINUE
+*
+*        Update singular vectors if desired
+*
+         IF( NRU.GT.0 )
+     $      CALL ZLASR( 'R', 'V', 'F', NRU, N, RWORK( 1 ), RWORK( N ),
+     $                  U, LDU )
+         IF( NCC.GT.0 )
+     $      CALL ZLASR( 'L', 'V', 'F', N, NCC, RWORK( 1 ), RWORK( N ),
+     $                  C, LDC )
+      END IF
+*
+*     Compute singular values to relative accuracy TOL
+*     (By setting TOL to be negative, algorithm will compute
+*     singular values to absolute accuracy ABS(TOL)*norm(input matrix))
+*
+      TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
+      TOL = TOLMUL*EPS
+*
+*     Compute approximate maximum, minimum singular values
+*
+      SMAX = ZERO
+      DO 20 I = 1, N
+         SMAX = MAX( SMAX, ABS( D( I ) ) )
+   20 CONTINUE
+      DO 30 I = 1, N - 1
+         SMAX = MAX( SMAX, ABS( E( I ) ) )
+   30 CONTINUE
+      SMINL = ZERO
+      IF( TOL.GE.ZERO ) THEN
+*
+*        Relative accuracy desired
+*
+         SMINOA = ABS( D( 1 ) )
+         IF( SMINOA.EQ.ZERO )
+     $      GO TO 50
+         MU = SMINOA
+         DO 40 I = 2, N
+            MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+            SMINOA = MIN( SMINOA, MU )
+            IF( SMINOA.EQ.ZERO )
+     $         GO TO 50
+   40    CONTINUE
+   50    CONTINUE
+         SMINOA = SMINOA / SQRT( DBLE( N ) )
+         THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
+      ELSE
+*
+*        Absolute accuracy desired
+*
+         THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
+      END IF
+*
+*     Prepare for main iteration loop for the singular values
+*     (MAXIT is the maximum number of passes through the inner
+*     loop permitted before nonconvergence signalled.)
+*
+      MAXIT = MAXITR*N*N
+      ITER = 0
+      OLDLL = -1
+      OLDM = -1
+*
+*     M points to last element of unconverged part of matrix
+*
+      M = N
+*
+*     Begin main iteration loop
+*
+   60 CONTINUE
+*
+*     Check for convergence or exceeding iteration count
+*
+      IF( M.LE.1 )
+     $   GO TO 160
+      IF( ITER.GT.MAXIT )
+     $   GO TO 200
+*
+*     Find diagonal block of matrix to work on
+*
+      IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
+     $   D( M ) = ZERO
+      SMAX = ABS( D( M ) )
+      SMIN = SMAX
+      DO 70 LLL = 1, M - 1
+         LL = M - LLL
+         ABSS = ABS( D( LL ) )
+         ABSE = ABS( E( LL ) )
+         IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
+     $      D( LL ) = ZERO
+         IF( ABSE.LE.THRESH )
+     $      GO TO 80
+         SMIN = MIN( SMIN, ABSS )
+         SMAX = MAX( SMAX, ABSS, ABSE )
+   70 CONTINUE
+      LL = 0
+      GO TO 90
+   80 CONTINUE
+      E( LL ) = ZERO
+*
+*     Matrix splits since E(LL) = 0
+*
+      IF( LL.EQ.M-1 ) THEN
+*
+*        Convergence of bottom singular value, return to top of loop
+*
+         M = M - 1
+         GO TO 60
+      END IF
+   90 CONTINUE
+      LL = LL + 1
+*
+*     E(LL) through E(M-1) are nonzero, E(LL-1) is zero
+*
+      IF( LL.EQ.M-1 ) THEN
+*
+*        2 by 2 block, handle separately
+*
+         CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
+     $                COSR, SINL, COSL )
+         D( M-1 ) = SIGMX
+         E( M-1 ) = ZERO
+         D( M ) = SIGMN
+*
+*        Compute singular vectors, if desired
+*
+         IF( NCVT.GT.0 )
+     $      CALL ZDROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT,
+     $                  COSR, SINR )
+         IF( NRU.GT.0 )
+     $      CALL ZDROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+         IF( NCC.GT.0 )
+     $      CALL ZDROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
+     $                  SINL )
+         M = M - 2
+         GO TO 60
+      END IF
+*
+*     If working on new submatrix, choose shift direction
+*     (from larger end diagonal element towards smaller)
+*
+      IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
+         IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
+*
+*           Chase bulge from top (big end) to bottom (small end)
+*
+            IDIR = 1
+         ELSE
+*
+*           Chase bulge from bottom (big end) to top (small end)
+*
+            IDIR = 2
+         END IF
+      END IF
+*
+*     Apply convergence tests
+*
+      IF( IDIR.EQ.1 ) THEN
+*
+*        Run convergence test in forward direction
+*        First apply standard test to bottom of matrix
+*
+         IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
+     $       ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
+            E( M-1 ) = ZERO
+            GO TO 60
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion forward
+*
+            MU = ABS( D( LL ) )
+            SMINL = MU
+            DO 100 LLL = LL, M - 1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 60
+               END IF
+               MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  100       CONTINUE
+         END IF
+*
+      ELSE
+*
+*        Run convergence test in backward direction
+*        First apply standard test to top of matrix
+*
+         IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
+     $       ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
+            E( LL ) = ZERO
+            GO TO 60
+         END IF
+*
+         IF( TOL.GE.ZERO ) THEN
+*
+*           If relative accuracy desired,
+*           apply convergence criterion backward
+*
+            MU = ABS( D( M ) )
+            SMINL = MU
+            DO 110 LLL = M - 1, LL, -1
+               IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+                  E( LLL ) = ZERO
+                  GO TO 60
+               END IF
+               MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+               SMINL = MIN( SMINL, MU )
+  110       CONTINUE
+         END IF
+      END IF
+      OLDLL = LL
+      OLDM = M
+*
+*     Compute shift.  First, test if shifting would ruin relative
+*     accuracy, and if so set the shift to zero.
+*
+      IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
+     $    MAX( EPS, HNDRTH*TOL ) ) THEN
+*
+*        Use a zero shift to avoid loss of relative accuracy
+*
+         SHIFT = ZERO
+      ELSE
+*
+*        Compute the shift from 2-by-2 block at end of matrix
+*
+         IF( IDIR.EQ.1 ) THEN
+            SLL = ABS( D( LL ) )
+            CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+         ELSE
+            SLL = ABS( D( M ) )
+            CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
+         END IF
+*
+*        Test if shift negligible, and if so set to zero
+*
+         IF( SLL.GT.ZERO ) THEN
+            IF( ( SHIFT / SLL )**2.LT.EPS )
+     $         SHIFT = ZERO
+         END IF
+      END IF
+*
+*     Increment iteration count
+*
+      ITER = ITER + M - LL
+*
+*     If SHIFT = 0, do simplified QR iteration
+*
+      IF( SHIFT.EQ.ZERO ) THEN
+         IF( IDIR.EQ.1 ) THEN
+*
+*           Chase bulge from top to bottom
+*           Save cosines and sines for later singular vector updates
+*
+            CS = ONE
+            OLDCS = ONE
+            DO 120 I = LL, M - 1
+               CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+               RWORK( I-LL+1 ) = CS
+               RWORK( I-LL+1+NM1 ) = SN
+               RWORK( I-LL+1+NM12 ) = OLDCS
+               RWORK( I-LL+1+NM13 ) = OLDSN
+  120       CONTINUE
+            H = D( M )*CS
+            D( M ) = H*OLDCS
+            E( M-1 ) = H*OLDSN
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
+     $                     RWORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( M-1 ) ).LE.THRESH )
+     $         E( M-1 ) = ZERO
+*
+         ELSE
+*
+*           Chase bulge from bottom to top
+*           Save cosines and sines for later singular vector updates
+*
+            CS = ONE
+            OLDCS = ONE
+            DO 130 I = M, LL + 1, -1
+               CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+               IF( I.LT.M )
+     $            E( I ) = OLDSN*R
+               CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+               RWORK( I-LL ) = CS
+               RWORK( I-LL+NM1 ) = -SN
+               RWORK( I-LL+NM12 ) = OLDCS
+               RWORK( I-LL+NM13 ) = -OLDSN
+  130       CONTINUE
+            H = D( LL )*CS
+            D( LL ) = H*OLDCS
+            E( LL ) = H*OLDSN
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
+     $                     RWORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
+     $                     RWORK( N ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( LL ) ).LE.THRESH )
+     $         E( LL ) = ZERO
+         END IF
+      ELSE
+*
+*        Use nonzero shift
+*
+         IF( IDIR.EQ.1 ) THEN
+*
+*           Chase bulge from top to bottom
+*           Save cosines and sines for later singular vector updates
+*
+            F = ( ABS( D( LL ) )-SHIFT )*
+     $          ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
+            G = E( LL )
+            DO 140 I = LL, M - 1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               IF( I.GT.LL )
+     $            E( I-1 ) = R
+               F = COSR*D( I ) + SINR*E( I )
+               E( I ) = COSR*E( I ) - SINR*D( I )
+               G = SINR*D( I+1 )
+               D( I+1 ) = COSR*D( I+1 )
+               CALL DLARTG( F, G, COSL, SINL, R )
+               D( I ) = R
+               F = COSL*E( I ) + SINL*D( I+1 )
+               D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
+               IF( I.LT.M-1 ) THEN
+                  G = SINL*E( I+1 )
+                  E( I+1 ) = COSL*E( I+1 )
+               END IF
+               RWORK( I-LL+1 ) = COSR
+               RWORK( I-LL+1+NM1 ) = SINR
+               RWORK( I-LL+1+NM12 ) = COSL
+               RWORK( I-LL+1+NM13 ) = SINL
+  140       CONTINUE
+            E( M-1 ) = F
+*
+*           Update singular vectors
+*
+            IF( NCVT.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCVT, RWORK( 1 ),
+     $                     RWORK( N ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL ZLASR( 'R', 'V', 'F', NRU, M-LL+1, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'F', M-LL+1, NCC, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+*           Test convergence
+*
+            IF( ABS( E( M-1 ) ).LE.THRESH )
+     $         E( M-1 ) = ZERO
+*
+         ELSE
+*
+*           Chase bulge from bottom to top
+*           Save cosines and sines for later singular vector updates
+*
+            F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
+     $          D( M ) )
+            G = E( M-1 )
+            DO 150 I = M, LL + 1, -1
+               CALL DLARTG( F, G, COSR, SINR, R )
+               IF( I.LT.M )
+     $            E( I ) = R
+               F = COSR*D( I ) + SINR*E( I-1 )
+               E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
+               G = SINR*D( I-1 )
+               D( I-1 ) = COSR*D( I-1 )
+               CALL DLARTG( F, G, COSL, SINL, R )
+               D( I ) = R
+               F = COSL*E( I-1 ) + SINL*D( I-1 )
+               D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
+               IF( I.GT.LL+1 ) THEN
+                  G = SINL*E( I-2 )
+                  E( I-2 ) = COSL*E( I-2 )
+               END IF
+               RWORK( I-LL ) = COSR
+               RWORK( I-LL+NM1 ) = -SINR
+               RWORK( I-LL+NM12 ) = COSL
+               RWORK( I-LL+NM13 ) = -SINL
+  150       CONTINUE
+            E( LL ) = F
+*
+*           Test convergence
+*
+            IF( ABS( E( LL ) ).LE.THRESH )
+     $         E( LL ) = ZERO
+*
+*           Update singular vectors if desired
+*
+            IF( NCVT.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCVT, RWORK( NM12+1 ),
+     $                     RWORK( NM13+1 ), VT( LL, 1 ), LDVT )
+            IF( NRU.GT.0 )
+     $         CALL ZLASR( 'R', 'V', 'B', NRU, M-LL+1, RWORK( 1 ),
+     $                     RWORK( N ), U( 1, LL ), LDU )
+            IF( NCC.GT.0 )
+     $         CALL ZLASR( 'L', 'V', 'B', M-LL+1, NCC, RWORK( 1 ),
+     $                     RWORK( N ), C( LL, 1 ), LDC )
+         END IF
+      END IF
+*
+*     QR iteration finished, go back and check convergence
+*
+      GO TO 60
+*
+*     All singular values converged, so make them positive
+*
+  160 CONTINUE
+      DO 170 I = 1, N
+         IF( D( I ).LT.ZERO ) THEN
+            D( I ) = -D( I )
+*
+*           Change sign of singular vectors, if desired
+*
+            IF( NCVT.GT.0 )
+     $         CALL ZDSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
+         END IF
+  170 CONTINUE
+*
+*     Sort the singular values into decreasing order (insertion sort on
+*     singular values, but only one transposition per singular vector)
+*
+      DO 190 I = 1, N - 1
+*
+*        Scan for smallest D(I)
+*
+         ISUB = 1
+         SMIN = D( 1 )
+         DO 180 J = 2, N + 1 - I
+            IF( D( J ).LE.SMIN ) THEN
+               ISUB = J
+               SMIN = D( J )
+            END IF
+  180    CONTINUE
+         IF( ISUB.NE.N+1-I ) THEN
+*
+*           Swap singular values and vectors
+*
+            D( ISUB ) = D( N+1-I )
+            D( N+1-I ) = SMIN
+            IF( NCVT.GT.0 )
+     $         CALL ZSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+     $                     LDVT )
+            IF( NRU.GT.0 )
+     $         CALL ZSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+            IF( NCC.GT.0 )
+     $         CALL ZSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
+         END IF
+  190 CONTINUE
+      GO TO 220
+*
+*     Maximum number of iterations exceeded, failure to converge
+*
+  200 CONTINUE
+      INFO = 0
+      DO 210 I = 1, N - 1
+         IF( E( I ).NE.ZERO )
+     $      INFO = INFO + 1
+  210 CONTINUE
+  220 CONTINUE
+      RETURN
+*
+*     End of ZBDSQR
+*
+      END
diff --git a/src/lib/lapack/zdrot.f b/src/lib/lapack/zdrot.f
new file mode 100644
index 00000000..3b946e99
--- /dev/null
+++ b/src/lib/lapack/zdrot.f
@@ -0,0 +1,96 @@
+      SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, INCY, N
+      DOUBLE PRECISION   C, S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * ), CY( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  Applies a plane rotation, where the cos and sin (c and s) are real
+*  and the vectors cx and cy are complex.
+*  jack dongarra, linpack, 3/11/78.
+*
+*  Arguments
+*  ==========
+*
+*  N        (input) INTEGER
+*           On entry, N specifies the order of the vectors cx and cy.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  CX       (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array CX must contain the n
+*           element vector cx. On exit, CX is overwritten by the updated
+*           vector cx.
+*
+*  INCX     (input) INTEGER
+*           On entry, INCX specifies the increment for the elements of
+*           CX. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  CY       (input) COMPLEX*16 array, dimension at least
+*           ( 1 + ( N - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array CY must contain the n
+*           element vector cy. On exit, CY is overwritten by the updated
+*           vector cy.
+*
+*  INCY     (input) INTEGER
+*           On entry, INCY specifies the increment for the elements of
+*           CY. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  C        (input) DOUBLE PRECISION
+*           On entry, C specifies the cosine, cos.
+*           Unchanged on exit.
+*
+*  S        (input) DOUBLE PRECISION
+*           On entry, S specifies the sine, sin.
+*           Unchanged on exit.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX, IY
+      COMPLEX*16         CTEMP
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 )
+     $   RETURN
+      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
+     $   GO TO 20
+*
+*        code for unequal increments or equal increments not equal
+*          to 1
+*
+      IX = 1
+      IY = 1
+      IF( INCX.LT.0 )
+     $   IX = ( -N+1 )*INCX + 1
+      IF( INCY.LT.0 )
+     $   IY = ( -N+1 )*INCY + 1
+      DO 10 I = 1, N
+         CTEMP = C*CX( IX ) + S*CY( IY )
+         CY( IY ) = C*CY( IY ) - S*CX( IX )
+         CX( IX ) = CTEMP
+         IX = IX + INCX
+         IY = IY + INCY
+   10 CONTINUE
+      RETURN
+*
+*        code for both increments equal to 1
+*
+   20 CONTINUE
+      DO 30 I = 1, N
+         CTEMP = C*CX( I ) + S*CY( I )
+         CY( I ) = C*CY( I ) - S*CX( I )
+         CX( I ) = CTEMP
+   30 CONTINUE
+      RETURN
+      END
diff --git a/src/lib/lapack/zdrscl.f b/src/lib/lapack/zdrscl.f
new file mode 100644
index 00000000..11686d0b
--- /dev/null
+++ b/src/lib/lapack/zdrscl.f
@@ -0,0 +1,114 @@
+      SUBROUTINE ZDRSCL( N, SA, SX, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   SA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         SX( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZDRSCL multiplies an n-element complex vector x by the real scalar
+*  1/a.  This is done without overflow or underflow as long as
+*  the final result x/a does not overflow or underflow.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of components of the vector x.
+*
+*  SA      (input) DOUBLE PRECISION
+*          The scalar a which is used to divide each component of x.
+*          SA must be >= 0, or the subroutine will divide by zero.
+*
+*  SX      (input/output) COMPLEX*16 array, dimension
+*                         (1+(N-1)*abs(INCX))
+*          The n-element vector x.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of the vector SX.
+*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      DOUBLE PRECISION   BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZDSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Initialize the denominator to SA and the numerator to 1.
+*
+      CDEN = SA
+      CNUM = ONE
+*
+   10 CONTINUE
+      CDEN1 = CDEN*SMLNUM
+      CNUM1 = CNUM / BIGNUM
+      IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
+*
+*        Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
+*
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CDEN = CDEN1
+      ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
+*
+*        Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
+*
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CNUM = CNUM1
+      ELSE
+*
+*        Multiply X by CNUM / CDEN and return.
+*
+         MUL = CNUM / CDEN
+         DONE = .TRUE.
+      END IF
+*
+*     Scale the vector X by MUL
+*
+      CALL ZDSCAL( N, MUL, SX, INCX )
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of ZDRSCL
+*
+      END
diff --git a/src/lib/lapack/zgebak.f b/src/lib/lapack/zgebak.f
new file mode 100644
index 00000000..1023601d
--- /dev/null
+++ b/src/lib/lapack/zgebak.f
@@ -0,0 +1,189 @@
+      SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB, SIDE
+      INTEGER            IHI, ILO, INFO, LDV, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   SCALE( * )
+      COMPLEX*16         V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEBAK forms the right or left eigenvectors of a complex general
+*  matrix by backward transformation on the computed eigenvectors of the
+*  balanced matrix output by ZGEBAL.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the type of backward transformation required:
+*          = 'N', do nothing, return immediately;
+*          = 'P', do backward transformation for permutation only;
+*          = 'S', do backward transformation for scaling only;
+*          = 'B', do backward transformations for both permutation and
+*                 scaling.
+*          JOB must be the same as the argument JOB supplied to ZGEBAL.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  V contains right eigenvectors;
+*          = 'L':  V contains left eigenvectors.
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrix V.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          The integers ILO and IHI determined by ZGEBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  SCALE   (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutation and scaling factors, as returned
+*          by ZGEBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) COMPLEX*16 array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by ZHSEIN or ZTREVC.
+*          On exit, V is overwritten by the transformed eigenvectors.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V. LDV >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, II, K
+      DOUBLE PRECISION   S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test the input parameters
+*
+      RIGHTV = LSAME( SIDE, 'R' )
+      LEFTV = LSAME( SIDE, 'L' )
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -7
+      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEBAK', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( LSAME( JOB, 'N' ) )
+     $   RETURN
+*
+      IF( ILO.EQ.IHI )
+     $   GO TO 30
+*
+*     Backward balance
+*
+      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+         IF( RIGHTV ) THEN
+            DO 10 I = ILO, IHI
+               S = SCALE( I )
+               CALL ZDSCAL( M, S, V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               S = ONE / SCALE( I )
+               CALL ZDSCAL( M, S, V( I, 1 ), LDV )
+   20       CONTINUE
+         END IF
+*
+      END IF
+*
+*     Backward permutation
+*
+*     For  I = ILO-1 step -1 until 1,
+*              IHI+1 step 1 until N do --
+*
+   30 CONTINUE
+      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+         IF( RIGHTV ) THEN
+            DO 40 II = 1, N
+               I = II
+               IF( I.GE.ILO .AND. I.LE.IHI )
+     $            GO TO 40
+               IF( I.LT.ILO )
+     $            I = ILO - II
+               K = SCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 40
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   40       CONTINUE
+         END IF
+*
+         IF( LEFTV ) THEN
+            DO 50 II = 1, N
+               I = II
+               IF( I.GE.ILO .AND. I.LE.IHI )
+     $            GO TO 50
+               IF( I.LT.ILO )
+     $            I = ILO - II
+               K = SCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 50
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   50       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZGEBAK
+*
+      END
diff --git a/src/lib/lapack/zgebal.f b/src/lib/lapack/zgebal.f
new file mode 100644
index 00000000..67ac2e14
--- /dev/null
+++ b/src/lib/lapack/zgebal.f
@@ -0,0 +1,330 @@
+      SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            IHI, ILO, INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   SCALE( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEBAL balances a general complex matrix A.  This involves, first,
+*  permuting A by a similarity transformation to isolate eigenvalues
+*  in the first 1 to ILO-1 and last IHI+1 to N elements on the
+*  diagonal; and second, applying a diagonal similarity transformation
+*  to rows and columns ILO to IHI to make the rows and columns as
+*  close in norm as possible.  Both steps are optional.
+*
+*  Balancing may reduce the 1-norm of the matrix, and improve the
+*  accuracy of the computed eigenvalues and/or eigenvectors.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the operations to be performed on A:
+*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+*                  for i = 1,...,N;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the input matrix A.
+*          On exit,  A is overwritten by the balanced matrix.
+*          If JOB = 'N', A is not referenced.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are set to integers such that on exit
+*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  SCALE   (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied to
+*          A.  If P(j) is the index of the row and column interchanged
+*          with row and column j and D(j) is the scaling factor
+*          applied to row and column j, then
+*          SCALE(j) = P(j)    for j = 1,...,ILO-1
+*                   = D(j)    for j = ILO,...,IHI
+*                   = P(j)    for j = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The permutations consist of row and column interchanges which put
+*  the matrix in the form
+*
+*             ( T1   X   Y  )
+*     P A P = (  0   B   Z  )
+*             (  0   0   T2 )
+*
+*  where T1 and T2 are upper triangular matrices whose eigenvalues lie
+*  along the diagonal.  The column indices ILO and IHI mark the starting
+*  and ending columns of the submatrix B. Balancing consists of applying
+*  a diagonal similarity transformation inv(D) * B * D to make the
+*  1-norms of each row of B and its corresponding column nearly equal.
+*  The output matrix is
+*
+*     ( T1     X*D          Y    )
+*     (  0  inv(D)*B*D  inv(D)*Z ).
+*     (  0      0           T2   )
+*
+*  Information about the permutations P and the diagonal matrix D is
+*  returned in the vector SCALE.
+*
+*  This subroutine is based on the EISPACK routine CBAL.
+*
+*  Modified by Tzu-Yi Chen, Computer Science Division, University of
+*    California at Berkeley, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   SCLFAC
+      PARAMETER          ( SCLFAC = 2.0D+0 )
+      DOUBLE PRECISION   FACTOR
+      PARAMETER          ( FACTOR = 0.95D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOCONV
+      INTEGER            I, ICA, IEXC, IRA, J, K, L, M
+      DOUBLE PRECISION   C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+     $                   SFMIN2
+      COMPLEX*16         CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IZAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEBAL', -INFO )
+         RETURN
+      END IF
+*
+      K = 1
+      L = N
+*
+      IF( N.EQ.0 )
+     $   GO TO 210
+*
+      IF( LSAME( JOB, 'N' ) ) THEN
+         DO 10 I = 1, N
+            SCALE( I ) = ONE
+   10    CONTINUE
+         GO TO 210
+      END IF
+*
+      IF( LSAME( JOB, 'S' ) )
+     $   GO TO 120
+*
+*     Permutation to isolate eigenvalues if possible
+*
+      GO TO 50
+*
+*     Row and column exchange.
+*
+   20 CONTINUE
+      SCALE( M ) = J
+      IF( J.EQ.M )
+     $   GO TO 30
+*
+      CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL ZSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
+*
+   30 CONTINUE
+      GO TO ( 40, 80 )IEXC
+*
+*     Search for rows isolating an eigenvalue and push them down.
+*
+   40 CONTINUE
+      IF( L.EQ.1 )
+     $   GO TO 210
+      L = L - 1
+*
+   50 CONTINUE
+      DO 70 J = L, 1, -1
+*
+         DO 60 I = 1, L
+            IF( I.EQ.J )
+     $         GO TO 60
+            IF( DBLE( A( J, I ) ).NE.ZERO .OR. DIMAG( A( J, I ) ).NE.
+     $          ZERO )GO TO 70
+   60    CONTINUE
+*
+         M = L
+         IEXC = 1
+         GO TO 20
+   70 CONTINUE
+*
+      GO TO 90
+*
+*     Search for columns isolating an eigenvalue and push them left.
+*
+   80 CONTINUE
+      K = K + 1
+*
+   90 CONTINUE
+      DO 110 J = K, L
+*
+         DO 100 I = K, L
+            IF( I.EQ.J )
+     $         GO TO 100
+            IF( DBLE( A( I, J ) ).NE.ZERO .OR. DIMAG( A( I, J ) ).NE.
+     $          ZERO )GO TO 110
+  100    CONTINUE
+*
+         M = K
+         IEXC = 2
+         GO TO 20
+  110 CONTINUE
+*
+  120 CONTINUE
+      DO 130 I = K, L
+         SCALE( I ) = ONE
+  130 CONTINUE
+*
+      IF( LSAME( JOB, 'P' ) )
+     $   GO TO 210
+*
+*     Balance the submatrix in rows K to L.
+*
+*     Iterative loop for norm reduction
+*
+      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      SFMAX1 = ONE / SFMIN1
+      SFMIN2 = SFMIN1*SCLFAC
+      SFMAX2 = ONE / SFMIN2
+  140 CONTINUE
+      NOCONV = .FALSE.
+*
+      DO 200 I = K, L
+         C = ZERO
+         R = ZERO
+*
+         DO 150 J = K, L
+            IF( J.EQ.I )
+     $         GO TO 150
+            C = C + CABS1( A( J, I ) )
+            R = R + CABS1( A( I, J ) )
+  150    CONTINUE
+         ICA = IZAMAX( L, A( 1, I ), 1 )
+         CA = ABS( A( ICA, I ) )
+         IRA = IZAMAX( N-K+1, A( I, K ), LDA )
+         RA = ABS( A( I, IRA+K-1 ) )
+*
+*        Guard against zero C or R due to underflow.
+*
+         IF( C.EQ.ZERO .OR. R.EQ.ZERO )
+     $      GO TO 200
+         G = R / SCLFAC
+         F = ONE
+         S = C + R
+  160    CONTINUE
+         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
+     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
+         F = F*SCLFAC
+         C = C*SCLFAC
+         CA = CA*SCLFAC
+         R = R / SCLFAC
+         G = G / SCLFAC
+         RA = RA / SCLFAC
+         GO TO 160
+*
+  170    CONTINUE
+         G = C / SCLFAC
+  180    CONTINUE
+         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
+     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
+         F = F / SCLFAC
+         C = C / SCLFAC
+         G = G / SCLFAC
+         CA = CA / SCLFAC
+         R = R*SCLFAC
+         RA = RA*SCLFAC
+         GO TO 180
+*
+*        Now balance.
+*
+  190    CONTINUE
+         IF( ( C+R ).GE.FACTOR*S )
+     $      GO TO 200
+         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
+            IF( F*SCALE( I ).LE.SFMIN1 )
+     $         GO TO 200
+         END IF
+         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
+            IF( SCALE( I ).GE.SFMAX1 / F )
+     $         GO TO 200
+         END IF
+         G = ONE / F
+         SCALE( I ) = SCALE( I )*F
+         NOCONV = .TRUE.
+*
+         CALL ZDSCAL( N-K+1, G, A( I, K ), LDA )
+         CALL ZDSCAL( L, F, A( 1, I ), 1 )
+*
+  200 CONTINUE
+*
+      IF( NOCONV )
+     $   GO TO 140
+*
+  210 CONTINUE
+      ILO = K
+      IHI = L
+*
+      RETURN
+*
+*     End of ZGEBAL
+*
+      END
diff --git a/src/lib/lapack/zgebd2.f b/src/lib/lapack/zgebd2.f
new file mode 100644
index 00000000..5ba52e87
--- /dev/null
+++ b/src/lib/lapack/zgebd2.f
@@ -0,0 +1,250 @@
+      SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEBD2 reduces a complex general m by n matrix A to upper or lower
+*  real bidiagonal form B by a unitary transformation: Q' * A * P = B.
+*
+*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n general matrix to be reduced.
+*          On exit,
+*          if m >= n, the diagonal and the first superdiagonal are
+*            overwritten with the upper bidiagonal matrix B; the
+*            elements below the diagonal, with the array TAUQ, represent
+*            the unitary matrix Q as a product of elementary
+*            reflectors, and the elements above the first superdiagonal,
+*            with the array TAUP, represent the unitary matrix P as
+*            a product of elementary reflectors;
+*          if m < n, the diagonal and the first subdiagonal are
+*            overwritten with the lower bidiagonal matrix B; the
+*            elements below the first subdiagonal, with the array TAUQ,
+*            represent the unitary matrix Q as a product of
+*            elementary reflectors, and the elements above the diagonal,
+*            with the array TAUP, represent the unitary matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The off-diagonal elements of the bidiagonal matrix B:
+*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+*  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix P. See Further Details.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (max(M,N))
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*  If m >= n,
+*
+*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are complex scalars, and v and u are complex
+*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
+*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
+*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n,
+*
+*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are complex scalars, v and u are complex vectors;
+*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+*  tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The contents of A on exit are illustrated by the following examples:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
+*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
+*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
+*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
+*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
+*    (  v1  v2  v3  v4  v5 )
+*
+*  where d and e denote diagonal and off-diagonal elements of B, vi
+*  denotes an element of the vector defining H(i), and ui an element of
+*  the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'ZGEBD2', -INFO )
+         RETURN
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        Reduce to upper bidiagonal form
+*
+         DO 10 I = 1, N
+*
+*           Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+            ALPHA = A( I, I )
+            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
+     $                   TAUQ( I ) )
+            D( I ) = ALPHA
+            A( I, I ) = ONE
+*
+*           Apply H(i)' to A(i:m,i+1:n) from the left
+*
+            IF( I.LT.N )
+     $         CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                     DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK )
+            A( I, I ) = D( I )
+*
+            IF( I.LT.N ) THEN
+*
+*              Generate elementary reflector G(i) to annihilate
+*              A(i,i+2:n)
+*
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               ALPHA = A( I, I+1 )
+               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
+     $                      TAUP( I ) )
+               E( I ) = ALPHA
+               A( I, I+1 ) = ONE
+*
+*              Apply G(i) to A(i+1:m,i+1:n) from the right
+*
+               CALL ZLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+     $                     TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               A( I, I+1 ) = E( I )
+            ELSE
+               TAUP( I ) = ZERO
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Reduce to lower bidiagonal form
+*
+         DO 20 I = 1, M
+*
+*           Generate elementary reflector G(i) to annihilate A(i,i+1:n)
+*
+            CALL ZLACGV( N-I+1, A( I, I ), LDA )
+            ALPHA = A( I, I )
+            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+     $                   TAUP( I ) )
+            D( I ) = ALPHA
+            A( I, I ) = ONE
+*
+*           Apply G(i) to A(i+1:m,i:n) from the right
+*
+            IF( I.LT.M )
+     $         CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     TAUP( I ), A( I+1, I ), LDA, WORK )
+            CALL ZLACGV( N-I+1, A( I, I ), LDA )
+            A( I, I ) = D( I )
+*
+            IF( I.LT.M ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(i+2:m,i)
+*
+               ALPHA = A( I+1, I )
+               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
+     $                      TAUQ( I ) )
+               E( I ) = ALPHA
+               A( I+1, I ) = ONE
+*
+*              Apply H(i)' to A(i+1:m,i+1:n) from the left
+*
+               CALL ZLARF( 'Left', M-I, N-I, A( I+1, I ), 1,
+     $                     DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA,
+     $                     WORK )
+               A( I+1, I ) = E( I )
+            ELSE
+               TAUQ( I ) = ZERO
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZGEBD2
+*
+      END
diff --git a/src/lib/lapack/zgebrd.f b/src/lib/lapack/zgebrd.f
new file mode 100644
index 00000000..4f97bd7e
--- /dev/null
+++ b/src/lib/lapack/zgebrd.f
@@ -0,0 +1,268 @@
+      SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
+*  bidiagonal form B by a unitary transformation: Q**H * A * P = B.
+*
+*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N general matrix to be reduced.
+*          On exit,
+*          if m >= n, the diagonal and the first superdiagonal are
+*            overwritten with the upper bidiagonal matrix B; the
+*            elements below the diagonal, with the array TAUQ, represent
+*            the unitary matrix Q as a product of elementary
+*            reflectors, and the elements above the first superdiagonal,
+*            with the array TAUP, represent the unitary matrix P as
+*            a product of elementary reflectors;
+*          if m < n, the diagonal and the first subdiagonal are
+*            overwritten with the lower bidiagonal matrix B; the
+*            elements below the first subdiagonal, with the array TAUQ,
+*            represent the unitary matrix Q as a product of
+*            elementary reflectors, and the elements above the diagonal,
+*            with the array TAUP, represent the unitary matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The diagonal elements of the bidiagonal matrix B:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+*          The off-diagonal elements of the bidiagonal matrix B:
+*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+*  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix P. See Further Details.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,M,N).
+*          For optimum performance LWORK >= (M+N)*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*  If m >= n,
+*
+*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are complex scalars, and v and u are complex
+*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
+*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
+*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n,
+*
+*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are complex scalars, and v and u are complex
+*  vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
+*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
+*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The contents of A on exit are illustrated by the following examples:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )
+*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )
+*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )
+*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )
+*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )
+*    (  v1  v2  v3  v4  v5 )
+*
+*  where d and e denote diagonal and off-diagonal elements of B, vi
+*  denotes an element of the vector defining H(i), and ui an element of
+*  the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+     $                   NBMIN, NX
+      DOUBLE PRECISION   WS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEBD2, ZGEMM, ZLABRD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MAX( 1, ILAENV( 1, 'ZGEBRD', ' ', M, N, -1, -1 ) )
+      LWKOPT = ( M+N )*NB
+      WORK( 1 ) = DBLE( LWKOPT )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.LT.0 ) THEN
+         CALL XERBLA( 'ZGEBRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      MINMN = MIN( M, N )
+      IF( MINMN.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      WS = MAX( M, N )
+      LDWRKX = M
+      LDWRKY = N
+*
+      IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+*        Set the crossover point NX.
+*
+         NX = MAX( NB, ILAENV( 3, 'ZGEBRD', ' ', M, N, -1, -1 ) )
+*
+*        Determine when to switch from blocked to unblocked code.
+*
+         IF( NX.LT.MINMN ) THEN
+            WS = ( M+N )*NB
+            IF( LWORK.LT.WS ) THEN
+*
+*              Not enough work space for the optimal NB, consider using
+*              a smaller block size.
+*
+               NBMIN = ILAENV( 2, 'ZGEBRD', ' ', M, N, -1, -1 )
+               IF( LWORK.GE.( M+N )*NBMIN ) THEN
+                  NB = LWORK / ( M+N )
+               ELSE
+                  NB = 1
+                  NX = MINMN
+               END IF
+            END IF
+         END IF
+      ELSE
+         NX = MINMN
+      END IF
+*
+      DO 30 I = 1, MINMN - NX, NB
+*
+*        Reduce rows and columns i:i+ib-1 to bidiagonal form and return
+*        the matrices X and Y which are needed to update the unreduced
+*        part of the matrix
+*
+         CALL ZLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
+     $                TAUQ( I ), TAUP( I ), WORK, LDWRKX,
+     $                WORK( LDWRKX*NB+1 ), LDWRKY )
+*
+*        Update the trailing submatrix A(i+ib:m,i+ib:n), using
+*        an update of the form  A := A - V*Y' - X*U'
+*
+         CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-I-NB+1,
+     $               N-I-NB+1, NB, -ONE, A( I+NB, I ), LDA,
+     $               WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
+     $               A( I+NB, I+NB ), LDA )
+         CALL ZGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
+     $               NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
+     $               ONE, A( I+NB, I+NB ), LDA )
+*
+*        Copy diagonal and off-diagonal elements of B back into A
+*
+         IF( M.GE.N ) THEN
+            DO 10 J = I, I + NB - 1
+               A( J, J ) = D( J )
+               A( J, J+1 ) = E( J )
+   10       CONTINUE
+         ELSE
+            DO 20 J = I, I + NB - 1
+               A( J, J ) = D( J )
+               A( J+1, J ) = E( J )
+   20       CONTINUE
+         END IF
+   30 CONTINUE
+*
+*     Use unblocked code to reduce the remainder of the matrix
+*
+      CALL ZGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $             TAUQ( I ), TAUP( I ), WORK, IINFO )
+      WORK( 1 ) = WS
+      RETURN
+*
+*     End of ZGEBRD
+*
+      END
diff --git a/src/lib/lapack/zgecon.f b/src/lib/lapack/zgecon.f
new file mode 100644
index 00000000..cfaaca35
--- /dev/null
+++ b/src/lib/lapack/zgecon.f
@@ -0,0 +1,193 @@
+      SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   ANORM, RCOND
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGECON estimates the reciprocal of the condition number of a general
+*  complex matrix A, in either the 1-norm or the infinity-norm, using
+*  the LU factorization computed by ZGETRF.
+*
+*  An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*  condition number is computed as
+*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies whether the 1-norm condition number or the
+*          infinity-norm condition number is required:
+*          = '1' or 'O':  1-norm;
+*          = 'I':         Infinity-norm.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by ZGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  ANORM   (input) DOUBLE PRECISION
+*          If NORM = '1' or 'O', the 1-norm of the original matrix A.
+*          If NORM = 'I', the infinity-norm of the original matrix A.
+*
+*  RCOND   (output) DOUBLE PRECISION
+*          The reciprocal of the condition number of the matrix A,
+*          computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ONENRM
+      CHARACTER          NORMIN
+      INTEGER            IX, KASE, KASE1
+      DOUBLE PRECISION   AINVNM, SCALE, SL, SMLNUM, SU
+      COMPLEX*16         ZDUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, IZAMAX, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDRSCL, ZLACN2, ZLATRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+      IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( ANORM.LT.ZERO ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGECON', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      RCOND = ZERO
+      IF( N.EQ.0 ) THEN
+         RCOND = ONE
+         RETURN
+      ELSE IF( ANORM.EQ.ZERO ) THEN
+         RETURN
+      END IF
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+*
+*     Estimate the norm of inv(A).
+*
+      AINVNM = ZERO
+      NORMIN = 'N'
+      IF( ONENRM ) THEN
+         KASE1 = 1
+      ELSE
+         KASE1 = 2
+      END IF
+      KASE = 0
+   10 CONTINUE
+      CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+      IF( KASE.NE.0 ) THEN
+         IF( KASE.EQ.KASE1 ) THEN
+*
+*           Multiply by inv(L).
+*
+            CALL ZLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+     $                   LDA, WORK, SL, RWORK, INFO )
+*
+*           Multiply by inv(U).
+*
+            CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+     $                   A, LDA, WORK, SU, RWORK( N+1 ), INFO )
+         ELSE
+*
+*           Multiply by inv(U').
+*
+            CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                   NORMIN, N, A, LDA, WORK, SU, RWORK( N+1 ),
+     $                   INFO )
+*
+*           Multiply by inv(L').
+*
+            CALL ZLATRS( 'Lower', 'Conjugate transpose', 'Unit', NORMIN,
+     $                   N, A, LDA, WORK, SL, RWORK, INFO )
+         END IF
+*
+*        Divide X by 1/(SL*SU) if doing so will not cause overflow.
+*
+         SCALE = SL*SU
+         NORMIN = 'Y'
+         IF( SCALE.NE.ONE ) THEN
+            IX = IZAMAX( N, WORK, 1 )
+            IF( SCALE.LT.CABS1( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+     $         GO TO 20
+            CALL ZDRSCL( N, SCALE, WORK, 1 )
+         END IF
+         GO TO 10
+      END IF
+*
+*     Compute the estimate of the reciprocal condition number.
+*
+      IF( AINVNM.NE.ZERO )
+     $   RCOND = ( ONE / AINVNM ) / ANORM
+*
+   20 CONTINUE
+      RETURN
+*
+*     End of ZGECON
+*
+      END
diff --git a/src/lib/lapack/zgees.f b/src/lib/lapack/zgees.f
new file mode 100644
index 00000000..ade5f9f2
--- /dev/null
+++ b/src/lib/lapack/zgees.f
@@ -0,0 +1,324 @@
+      SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS,
+     $                  LDVS, WORK, LWORK, RWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVS, SORT
+      INTEGER            INFO, LDA, LDVS, LWORK, N, SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELECT
+      EXTERNAL           SELECT
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
+*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur
+*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).
+*
+*  Optionally, it also orders the eigenvalues on the diagonal of the
+*  Schur form so that selected eigenvalues are at the top left.
+*  The leading columns of Z then form an orthonormal basis for the
+*  invariant subspace corresponding to the selected eigenvalues.
+*
+*  A complex matrix is in Schur form if it is upper triangular.
+*
+*  Arguments
+*  =========
+*
+*  JOBVS   (input) CHARACTER*1
+*          = 'N': Schur vectors are not computed;
+*          = 'V': Schur vectors are computed.
+*
+*  SORT    (input) CHARACTER*1
+*          Specifies whether or not to order the eigenvalues on the
+*          diagonal of the Schur form.
+*          = 'N': Eigenvalues are not ordered:
+*          = 'S': Eigenvalues are ordered (see SELECT).
+*
+*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument
+*          SELECT must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'S', SELECT is used to select eigenvalues to order
+*          to the top left of the Schur form.
+*          IF SORT = 'N', SELECT is not referenced.
+*          The eigenvalue W(j) is selected if SELECT(W(j)) is true.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten by its Schur form T.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  SDIM    (output) INTEGER
+*          If SORT = 'N', SDIM = 0.
+*          If SORT = 'S', SDIM = number of eigenvalues for which
+*                         SELECT is true.
+*
+*  W       (output) COMPLEX*16 array, dimension (N)
+*          W contains the computed eigenvalues, in the same order that
+*          they appear on the diagonal of the output Schur form T.
+*
+*  VS      (output) COMPLEX*16 array, dimension (LDVS,N)
+*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur
+*          vectors.
+*          If JOBVS = 'N', VS is not referenced.
+*
+*  LDVS    (input) INTEGER
+*          The leading dimension of the array VS.  LDVS >= 1; if
+*          JOBVS = 'V', LDVS >= N.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,2*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          Not referenced if SORT = 'N'.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*          > 0: if INFO = i, and i is
+*               <= N:  the QR algorithm failed to compute all the
+*                      eigenvalues; elements 1:ILO-1 and i+1:N of W
+*                      contain those eigenvalues which have converged;
+*                      if JOBVS = 'V', VS contains the matrix which
+*                      reduces A to its partially converged Schur form.
+*               = N+1: the eigenvalues could not be reordered because
+*                      some eigenvalues were too close to separate (the
+*                      problem is very ill-conditioned);
+*               = N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Schur form no longer satisfy
+*                      SELECT = .TRUE..  This could also be caused by
+*                      underflow due to scaling.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTST, WANTVS
+      INTEGER            HSWORK, I, IBAL, ICOND, IERR, IEVAL, IHI, ILO,
+     $                   ITAU, IWRK, MAXWRK, MINWRK
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEBAK, ZGEBAL, ZGEHRD,
+     $                   ZHSEQR, ZLACPY, ZLASCL, ZTRSEN, ZUNGHR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVS = LSAME( JOBVS, 'V' )
+      WANTST = LSAME( SORT, 'S' )
+      IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       CWorkspace refers to complex workspace, and RWorkspace to real
+*       workspace. NB refers to the optimal block size for the
+*       immediately following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by ZHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 2*N
+*
+            CALL ZHSEQR( 'S', JOBVS, N, 1, N, A, LDA, W, VS, LDVS,
+     $             WORK, -1, IEVAL )
+            HSWORK = WORK( 1 )
+*
+            IF( .NOT.WANTVS ) THEN
+               MAXWRK = MAX( MAXWRK, HSWORK )
+            ELSE
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               MAXWRK = MAX( MAXWRK, HSWORK )
+            END IF
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEES ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (CWorkspace: none)
+*     (RWorkspace: need N)
+*
+      IBAL = 1
+      CALL ZGEBAL( 'P', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
+*
+*     Reduce to upper Hessenberg form
+*     (CWorkspace: need 2*N, prefer N+N*NB)
+*     (RWorkspace: none)
+*
+      ITAU = 1
+      IWRK = N + ITAU
+      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVS ) THEN
+*
+*        Copy Householder vectors to VS
+*
+         CALL ZLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+*        Generate unitary matrix in VS
+*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+      END IF
+*
+      SDIM = 0
+*
+*     Perform QR iteration, accumulating Schur vectors in VS if desired
+*     (CWorkspace: need 1, prefer HSWORK (see comments) )
+*     (RWorkspace: none)
+*
+      IWRK = ITAU
+      CALL ZHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, W, VS, LDVS,
+     $             WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+      IF( IEVAL.GT.0 )
+     $   INFO = IEVAL
+*
+*     Sort eigenvalues if desired
+*
+      IF( WANTST .AND. INFO.EQ.0 ) THEN
+         IF( SCALEA )
+     $      CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, W, N, IERR )
+         DO 10 I = 1, N
+            BWORK( I ) = SELECT( W( I ) )
+   10    CONTINUE
+*
+*        Reorder eigenvalues and transform Schur vectors
+*        (CWorkspace: none)
+*        (RWorkspace: none)
+*
+         CALL ZTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, W, SDIM,
+     $                S, SEP, WORK( IWRK ), LWORK-IWRK+1, ICOND )
+      END IF
+*
+      IF( WANTVS ) THEN
+*
+*        Undo balancing
+*        (CWorkspace: none)
+*        (RWorkspace: need N)
+*
+         CALL ZGEBAK( 'P', 'R', N, ILO, IHI, RWORK( IBAL ), N, VS, LDVS,
+     $                IERR )
+      END IF
+*
+      IF( SCALEA ) THEN
+*
+*        Undo scaling for the Schur form of A
+*
+         CALL ZLASCL( 'U', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+         CALL ZCOPY( N, A, LDA+1, W, 1 )
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of ZGEES
+*
+      END
diff --git a/src/lib/lapack/zgeev.f b/src/lib/lapack/zgeev.f
new file mode 100644
index 00000000..0fa66307
--- /dev/null
+++ b/src/lib/lapack/zgeev.f
@@ -0,0 +1,396 @@
+      SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR,
+     $                  WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVL, JOBVR
+      INTEGER            INFO, LDA, LDVL, LDVR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
+*  eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+*  The right eigenvector v(j) of A satisfies
+*                   A * v(j) = lambda(j) * v(j)
+*  where lambda(j) is its eigenvalue.
+*  The left eigenvector u(j) of A satisfies
+*                u(j)**H * A = lambda(j) * u(j)**H
+*  where u(j)**H denotes the conjugate transpose of u(j).
+*
+*  The computed eigenvectors are normalized to have Euclidean norm
+*  equal to 1 and largest component real.
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N': left eigenvectors of A are not computed;
+*          = 'V': left eigenvectors of are computed.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N': right eigenvectors of A are not computed;
+*          = 'V': right eigenvectors of A are computed.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the N-by-N matrix A.
+*          On exit, A has been overwritten.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  W       (output) COMPLEX*16 array, dimension (N)
+*          W contains the computed eigenvalues.
+*
+*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left eigenvectors u(j) are stored one
+*          after another in the columns of VL, in the same order
+*          as their eigenvalues.
+*          If JOBVL = 'N', VL is not referenced.
+*          u(j) = VL(:,j), the j-th column of VL.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.  LDVL >= 1; if
+*          JOBVL = 'V', LDVL >= N.
+*
+*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right eigenvectors v(j) are stored one
+*          after another in the columns of VR, in the same order
+*          as their eigenvalues.
+*          If JOBVR = 'N', VR is not referenced.
+*          v(j) = VR(:,j), the j-th column of VR.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1; if
+*          JOBVR = 'V', LDVR >= N.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,2*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if INFO = i, the QR algorithm failed to compute all the
+*                eigenvalues, and no eigenvectors have been computed;
+*                elements and i+1:N of W contain eigenvalues which have
+*                converged.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SCALEA, WANTVL, WANTVR
+      CHARACTER          SIDE
+      INTEGER            HSWORK, I, IBAL, IERR, IHI, ILO, IRWORK, ITAU,
+     $                   IWRK, K, MAXWRK, MINWRK, NOUT
+      DOUBLE PRECISION   ANRM, BIGNUM, CSCALE, EPS, SCL, SMLNUM
+      COMPLEX*16         TMP
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            SELECT( 1 )
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZDSCAL, ZGEBAK, ZGEBAL, ZGEHRD,
+     $                   ZHSEQR, ZLACPY, ZLASCL, ZSCAL, ZTREVC, ZUNGHR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX, ILAENV
+      DOUBLE PRECISION   DLAMCH, DZNRM2, ZLANGE
+      EXTERNAL           LSAME, IDAMAX, ILAENV, DLAMCH, DZNRM2, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      WANTVL = LSAME( JOBVL, 'V' )
+      WANTVR = LSAME( JOBVR, 'V' )
+      IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       CWorkspace refers to complex workspace, and RWorkspace to real
+*       workspace. NB refers to the optimal block size for the
+*       immediately following subroutine, as returned by ILAENV.
+*       HSWORK refers to the workspace preferred by ZHSEQR, as
+*       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+*       the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            MINWRK = 1
+            MAXWRK = 1
+         ELSE
+            MAXWRK = N + N*ILAENV( 1, 'ZGEHRD', ' ', N, 1, N, 0 )
+            MINWRK = 2*N
+            IF( WANTVL ) THEN
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VL, LDVL,
+     $                WORK, -1, INFO )
+            ELSE IF( WANTVR ) THEN
+               MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'ZUNGHR',
+     $                       ' ', N, 1, N, -1 ) )
+               CALL ZHSEQR( 'S', 'V', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+            ELSE
+               CALL ZHSEQR( 'E', 'N', N, 1, N, A, LDA, W, VR, LDVR,
+     $                WORK, -1, INFO )
+            END IF
+            HSWORK = WORK( 1 )
+            MAXWRK = MAX( MAXWRK, HSWORK, MINWRK )
+         END IF
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -12
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', N, N, A, LDA, DUM )
+      SCALEA = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = SMLNUM
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         SCALEA = .TRUE.
+         CSCALE = BIGNUM
+      END IF
+      IF( SCALEA )
+     $   CALL ZLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+*     Balance the matrix
+*     (CWorkspace: none)
+*     (RWorkspace: need N)
+*
+      IBAL = 1
+      CALL ZGEBAL( 'B', N, A, LDA, ILO, IHI, RWORK( IBAL ), IERR )
+*
+*     Reduce to upper Hessenberg form
+*     (CWorkspace: need 2*N, prefer N+N*NB)
+*     (RWorkspace: none)
+*
+      ITAU = 1
+      IWRK = ITAU + N
+      CALL ZGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+     $             LWORK-IWRK+1, IERR )
+*
+      IF( WANTVL ) THEN
+*
+*        Want left eigenvectors
+*        Copy Householder vectors to VL
+*
+         SIDE = 'L'
+         CALL ZLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+*        Generate unitary matrix in VL
+*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VL
+*        (CWorkspace: need 1, prefer HSWORK (see comments) )
+*        (RWorkspace: none)
+*
+         IWRK = ITAU
+         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VL, LDVL,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+         IF( WANTVR ) THEN
+*
+*           Want left and right eigenvectors
+*           Copy Schur vectors to VR
+*
+            SIDE = 'B'
+            CALL ZLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+         END IF
+*
+      ELSE IF( WANTVR ) THEN
+*
+*        Want right eigenvectors
+*        Copy Householder vectors to VR
+*
+         SIDE = 'R'
+         CALL ZLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+*        Generate unitary matrix in VR
+*        (CWorkspace: need 2*N-1, prefer N+(N-1)*NB)
+*        (RWorkspace: none)
+*
+         CALL ZUNGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+     $                LWORK-IWRK+1, IERR )
+*
+*        Perform QR iteration, accumulating Schur vectors in VR
+*        (CWorkspace: need 1, prefer HSWORK (see comments) )
+*        (RWorkspace: none)
+*
+         IWRK = ITAU
+         CALL ZHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, W, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+      ELSE
+*
+*        Compute eigenvalues only
+*        (CWorkspace: need 1, prefer HSWORK (see comments) )
+*        (RWorkspace: none)
+*
+         IWRK = ITAU
+         CALL ZHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, W, VR, LDVR,
+     $                WORK( IWRK ), LWORK-IWRK+1, INFO )
+      END IF
+*
+*     If INFO > 0 from ZHSEQR, then quit
+*
+      IF( INFO.GT.0 )
+     $   GO TO 50
+*
+      IF( WANTVL .OR. WANTVR ) THEN
+*
+*        Compute left and/or right eigenvectors
+*        (CWorkspace: need 2*N)
+*        (RWorkspace: need 2*N)
+*
+         IRWORK = IBAL + N
+         CALL ZTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+     $                N, NOUT, WORK( IWRK ), RWORK( IRWORK ), IERR )
+      END IF
+*
+      IF( WANTVL ) THEN
+*
+*        Undo balancing of left eigenvectors
+*        (CWorkspace: none)
+*        (RWorkspace: need N)
+*
+         CALL ZGEBAK( 'B', 'L', N, ILO, IHI, RWORK( IBAL ), N, VL, LDVL,
+     $                IERR )
+*
+*        Normalize left eigenvectors and make largest component real
+*
+         DO 20 I = 1, N
+            SCL = ONE / DZNRM2( N, VL( 1, I ), 1 )
+            CALL ZDSCAL( N, SCL, VL( 1, I ), 1 )
+            DO 10 K = 1, N
+               RWORK( IRWORK+K-1 ) = DBLE( VL( K, I ) )**2 +
+     $                               DIMAG( VL( K, I ) )**2
+   10       CONTINUE
+            K = IDAMAX( N, RWORK( IRWORK ), 1 )
+            TMP = DCONJG( VL( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
+            CALL ZSCAL( N, TMP, VL( 1, I ), 1 )
+            VL( K, I ) = DCMPLX( DBLE( VL( K, I ) ), ZERO )
+   20    CONTINUE
+      END IF
+*
+      IF( WANTVR ) THEN
+*
+*        Undo balancing of right eigenvectors
+*        (CWorkspace: none)
+*        (RWorkspace: need N)
+*
+         CALL ZGEBAK( 'B', 'R', N, ILO, IHI, RWORK( IBAL ), N, VR, LDVR,
+     $                IERR )
+*
+*        Normalize right eigenvectors and make largest component real
+*
+         DO 40 I = 1, N
+            SCL = ONE / DZNRM2( N, VR( 1, I ), 1 )
+            CALL ZDSCAL( N, SCL, VR( 1, I ), 1 )
+            DO 30 K = 1, N
+               RWORK( IRWORK+K-1 ) = DBLE( VR( K, I ) )**2 +
+     $                               DIMAG( VR( K, I ) )**2
+   30       CONTINUE
+            K = IDAMAX( N, RWORK( IRWORK ), 1 )
+            TMP = DCONJG( VR( K, I ) ) / SQRT( RWORK( IRWORK+K-1 ) )
+            CALL ZSCAL( N, TMP, VR( 1, I ), 1 )
+            VR( K, I ) = DCMPLX( DBLE( VR( K, I ) ), ZERO )
+   40    CONTINUE
+      END IF
+*
+*     Undo scaling if necessary
+*
+   50 CONTINUE
+      IF( SCALEA ) THEN
+         CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, W( INFO+1 ),
+     $                MAX( N-INFO, 1 ), IERR )
+         IF( INFO.GT.0 ) THEN
+            CALL ZLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, W, N, IERR )
+         END IF
+      END IF
+*
+      WORK( 1 ) = MAXWRK
+      RETURN
+*
+*     End of ZGEEV
+*
+      END
diff --git a/src/lib/lapack/zgehd2.f b/src/lib/lapack/zgehd2.f
new file mode 100644
index 00000000..c73f4200
--- /dev/null
+++ b/src/lib/lapack/zgehd2.f
@@ -0,0 +1,148 @@
+      SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
+*  by a unitary similarity transformation:  Q' * A * Q = H .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          It is assumed that A is already upper triangular in rows
+*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*          set by a previous call to ZGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= max(1,N).
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the n by n general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          elements below the first subdiagonal, with the array TAU,
+*          represent the unitary matrix Q as a product of elementary
+*          reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of (ihi-ilo) elementary
+*  reflectors
+*
+*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*  exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+*  The contents of A are illustrated by the following example, with
+*  n = 7, ilo = 2 and ihi = 6:
+*
+*  on entry,                        on exit,
+*
+*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
+*  (                         a )    (                          a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEHD2', -INFO )
+         RETURN
+      END IF
+*
+      DO 10 I = ILO, IHI - 1
+*
+*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+         ALPHA = A( I+1, I )
+         CALL ZLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) )
+         A( I+1, I ) = ONE
+*
+*        Apply H(i) to A(1:ihi,i+1:ihi) from the right
+*
+         CALL ZLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+     $               A( 1, I+1 ), LDA, WORK )
+*
+*        Apply H(i)' to A(i+1:ihi,i+1:n) from the left
+*
+         CALL ZLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1,
+     $               DCONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK )
+*
+         A( I+1, I ) = ALPHA
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of ZGEHD2
+*
+      END
diff --git a/src/lib/lapack/zgehrd.f b/src/lib/lapack/zgehrd.f
new file mode 100644
index 00000000..83c1aa32
--- /dev/null
+++ b/src/lib/lapack/zgehrd.f
@@ -0,0 +1,273 @@
+      SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16        A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
+*  an unitary similarity transformation:  Q' * A * Q = H .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          It is assumed that A is already upper triangular in rows
+*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*          set by a previous call to ZGEBAL; otherwise they should be
+*          set to 1 and N respectively. See Further Details.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the N-by-N general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          elements below the first subdiagonal, with the array TAU,
+*          represent the unitary matrix Q as a product of elementary
+*          reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
+*          zero.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of (ihi-ilo) elementary
+*  reflectors
+*
+*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+*  exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+*  The contents of A are illustrated by the following example, with
+*  n = 7, ilo = 2 and ihi = 6:
+*
+*  on entry,                        on exit,
+*
+*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
+*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
+*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
+*  (                         a )    (                          a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  This file is a slight modification of LAPACK-3.0's ZGEHRD
+*  subroutine incorporating improvements proposed by Quintana-Orti and
+*  Van de Geijn (2005). 
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+      COMPLEX*16        ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ), 
+     $                     ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NH, NX
+      COMPLEX*16        EI
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16        T( LDT, NBMAX )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZGEHD2, ZGEMM, ZLAHR2, ZLARFB, ZTRMM,
+     $                   XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEHRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
+*
+      DO 10 I = 1, ILO - 1
+         TAU( I ) = ZERO
+   10 CONTINUE
+      DO 20 I = MAX( 1, IHI ), N - 1
+         TAU( I ) = ZERO
+   20 CONTINUE
+*
+*     Quick return if possible
+*
+      NH = IHI - ILO + 1
+      IF( NH.LE.1 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Determine the block size
+*
+      NB = MIN( NBMAX, ILAENV( 1, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
+      NBMIN = 2
+      IWS = 1
+      IF( NB.GT.1 .AND. NB.LT.NH ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code
+*        (last block is always handled by unblocked code)
+*
+         NX = MAX( NB, ILAENV( 3, 'ZGEHRD', ' ', N, ILO, IHI, -1 ) )
+         IF( NX.LT.NH ) THEN
+*
+*           Determine if workspace is large enough for blocked code
+*
+            IWS = N*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  determine the
+*              minimum value of NB, and reduce NB or force use of
+*              unblocked code
+*
+               NBMIN = MAX( 2, ILAENV( 2, 'ZGEHRD', ' ', N, ILO, IHI,
+     $                 -1 ) )
+               IF( LWORK.GE.N*NBMIN ) THEN
+                  NB = LWORK / N
+               ELSE
+                  NB = 1
+               END IF
+            END IF
+         END IF
+      END IF
+      LDWORK = N
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
+*
+*        Use unblocked code below
+*
+         I = ILO
+*
+      ELSE
+*
+*        Use blocked code
+*
+         DO 40 I = ILO, IHI - 1 - NX, NB
+            IB = MIN( NB, IHI-I )
+*
+*           Reduce columns i:i+ib-1 to Hessenberg form, returning the
+*           matrices V and T of the block reflector H = I - V*T*V'
+*           which performs the reduction, and also the matrix Y = A*V*T
+*
+            CALL ZLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
+     $                   WORK, LDWORK )
+*
+*           Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
+*           right, computing  A := A - Y * V'. V(i+ib,ib-1) must be set
+*           to 1
+*
+            EI = A( I+IB, I+IB-1 )
+            A( I+IB, I+IB-1 ) = ONE
+            CALL ZGEMM( 'No transpose', 'Conjugate transpose', 
+     $                  IHI, IHI-I-IB+1,
+     $                  IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
+     $                  A( 1, I+IB ), LDA )
+            A( I+IB, I+IB-1 ) = EI
+*
+*           Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
+*           right
+*
+            CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                  'Unit', I, IB-1,
+     $                  ONE, A( I+1, I ), LDA, WORK, LDWORK )
+            DO 30 J = 0, IB-2
+               CALL ZAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
+     $                     A( 1, I+J+1 ), 1 )
+   30       CONTINUE
+*
+*           Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
+*           left
+*
+            CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
+     $                   'Columnwise',
+     $                   IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
+     $                   A( I+1, I+IB ), LDA, WORK, LDWORK )
+   40    CONTINUE
+      END IF
+*
+*     Use unblocked code to reduce the rest of the matrix
+*
+      CALL ZGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+      WORK( 1 ) = IWS
+*
+      RETURN
+*
+*     End of ZGEHRD
+*
+      END
diff --git a/src/lib/lapack/zgelq2.f b/src/lib/lapack/zgelq2.f
new file mode 100644
index 00000000..dc387af0
--- /dev/null
+++ b/src/lib/lapack/zgelq2.f
@@ -0,0 +1,123 @@
+      SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m by min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
+*  A(i,i+1:n), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELQ2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+         CALL ZLACGV( N-I+1, A( I, I ), LDA )
+         ALPHA = A( I, I )
+         CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+     $                TAU( I ) )
+         IF( I.LT.M ) THEN
+*
+*           Apply H(i) to A(i+1:m,i:n) from the right
+*
+            A( I, I ) = ONE
+            CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+     $                  A( I+1, I ), LDA, WORK )
+         END IF
+         A( I, I ) = ALPHA
+         CALL ZLACGV( N-I+1, A( I, I ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGELQ2
+*
+      END
diff --git a/src/lib/lapack/zgelqf.f b/src/lib/lapack/zgelqf.f
new file mode 100644
index 00000000..5dac50dc
--- /dev/null
+++ b/src/lib/lapack/zgelqf.f
@@ -0,0 +1,195 @@
+      SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
+*  A = L * Q.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and below the diagonal of the array
+*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is
+*          lower triangular if m <= n); the elements above the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
+*  A(i,i+1:n), and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGELQ2, ZLARFB, ZLARFT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+      LWKOPT = M*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELQF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZGELQF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZGELQF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially
+*
+         DO 10 I = 1, K - NX, NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the LQ factorization of the current block
+*           A(i:i+ib-1,i:n)
+*
+            CALL ZGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+            IF( I+IB.LE.M ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(i+ib:m,i:n) from the right
+*
+               CALL ZLARFB( 'Right', 'No transpose', 'Forward',
+     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
+     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K )
+     $   CALL ZGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGELQF
+*
+      END
diff --git a/src/lib/lapack/zgelsy.f b/src/lib/lapack/zgelsy.f
new file mode 100644
index 00000000..684cf2c2
--- /dev/null
+++ b/src/lib/lapack/zgelsy.f
@@ -0,0 +1,385 @@
+      SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+     $                   WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+      DOUBLE PRECISION   RCOND
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGELSY computes the minimum-norm solution to a complex linear least
+*  squares problem:
+*      minimize || A * X - B ||
+*  using a complete orthogonal factorization of A.  A is an M-by-N
+*  matrix which may be rank-deficient.
+*
+*  Several right hand side vectors b and solution vectors x can be
+*  handled in a single call; they are stored as the columns of the
+*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+*  matrix X.
+*
+*  The routine first computes a QR factorization with column pivoting:
+*      A * P = Q * [ R11 R12 ]
+*                  [  0  R22 ]
+*  with R11 defined as the largest leading submatrix whose estimated
+*  condition number is less than 1/RCOND.  The order of R11, RANK,
+*  is the effective rank of A.
+*
+*  Then, R22 is considered to be negligible, and R12 is annihilated
+*  by unitary transformations from the right, arriving at the
+*  complete orthogonal factorization:
+*     A * P = Q * [ T11 0 ] * Z
+*                 [  0  0 ]
+*  The minimum-norm solution is then
+*     X = P * Z' [ inv(T11)*Q1'*B ]
+*                [        0       ]
+*  where Q1 consists of the first RANK columns of Q.
+*
+*  This routine is basically identical to the original xGELSX except
+*  three differences:
+*    o The permutation of matrix B (the right hand side) is faster and
+*      more simple.
+*    o The call to the subroutine xGEQPF has been substituted by the
+*      the call to the subroutine xGEQP3. This subroutine is a Blas-3
+*      version of the QR factorization with column pivoting.
+*    o Matrix B (the right hand side) is updated with Blas-3.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of
+*          columns of matrices B and X. NRHS >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, A has been overwritten by details of its
+*          complete orthogonal factorization.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the M-by-NRHS right hand side matrix B.
+*          On exit, the N-by-NRHS solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,M,N).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of AP, otherwise column i is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  RCOND   (input) DOUBLE PRECISION
+*          RCOND is used to determine the effective rank of A, which
+*          is defined as the order of the largest leading triangular
+*          submatrix R11 in the QR factorization with pivoting of A,
+*          whose estimated condition number < 1/RCOND.
+*
+*  RANK    (output) INTEGER
+*          The effective rank of A, i.e., the order of the submatrix
+*          R11.  This is the same as the order of the submatrix T11
+*          in the complete orthogonal factorization of A.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          The unblocked strategy requires that:
+*            LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
+*          where MN = min(M,N).
+*          The block algorithm requires that:
+*            LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
+*          where NB is an upper bound on the blocksize returned
+*          by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,
+*          and ZUNMRZ.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IMAX, IMIN
+      PARAMETER          ( IMAX = 1, IMIN = 2 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKOPT, MN,
+     $                   NB, NB1, NB2, NB3, NB4
+      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, SMAX, SMAXPR, SMIN, SMINPR,
+     $                   SMLNUM, WSIZE
+      COMPLEX*16         C1, C2, S1, S2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZCOPY, ZGEQP3, ZLAIC1, ZLASCL,
+     $                   ZLASET, ZTRSM, ZTZRZF, ZUNMQR, ZUNMRZ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M, N )
+      ISMIN = MN + 1
+      ISMAX = 2*MN + 1
+*
+*     Test the input arguments.
+*
+      INFO = 0
+      NB1 = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+      NB2 = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
+      NB3 = ILAENV( 1, 'ZUNMQR', ' ', M, N, NRHS, -1 )
+      NB4 = ILAENV( 1, 'ZUNMRQ', ' ', M, N, NRHS, -1 )
+      NB = MAX( NB1, NB2, NB3, NB4 )
+      LWKOPT = MAX( 1, MN+2*N+NB*( N+1 ), 2*MN+NB*NRHS )
+      WORK( 1 ) = DCMPLX( LWKOPT )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+         INFO = -7
+      ELSE IF( LWORK.LT.( MN+MAX( 2*MN, N+1, MN+NRHS ) ) .AND. .NOT.
+     $         LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGELSY', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+         RANK = 0
+         RETURN
+      END IF
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', M, N, A, LDA, RWORK )
+      IASCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+         IASCL = 1
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+         IASCL = 2
+      ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+*        Matrix all zero. Return zero solution.
+*
+         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         RANK = 0
+         GO TO 70
+      END IF
+*
+      BNRM = ZLANGE( 'M', M, NRHS, B, LDB, RWORK )
+      IBSCL = 0
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+*        Scale matrix norm up to SMLNUM
+*
+         CALL ZLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 1
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+*        Scale matrix norm down to BIGNUM
+*
+         CALL ZLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+         IBSCL = 2
+      END IF
+*
+*     Compute QR factorization with column pivoting of A:
+*        A * P = Q * R
+*
+      CALL ZGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+     $             LWORK-MN, RWORK, INFO )
+      WSIZE = MN + DBLE( WORK( MN+1 ) )
+*
+*     complex workspace: MN+NB*(N+1). real workspace 2*N.
+*     Details of Householder rotations stored in WORK(1:MN).
+*
+*     Determine RANK using incremental condition estimation
+*
+      WORK( ISMIN ) = CONE
+      WORK( ISMAX ) = CONE
+      SMAX = ABS( A( 1, 1 ) )
+      SMIN = SMAX
+      IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+         RANK = 0
+         CALL ZLASET( 'F', MAX( M, N ), NRHS, CZERO, CZERO, B, LDB )
+         GO TO 70
+      ELSE
+         RANK = 1
+      END IF
+*
+   10 CONTINUE
+      IF( RANK.LT.MN ) THEN
+         I = RANK + 1
+         CALL ZLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+     $                A( I, I ), SMINPR, S1, C1 )
+         CALL ZLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+     $                A( I, I ), SMAXPR, S2, C2 )
+*
+         IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+            DO 20 I = 1, RANK
+               WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+               WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+   20       CONTINUE
+            WORK( ISMIN+RANK ) = C1
+            WORK( ISMAX+RANK ) = C2
+            SMIN = SMINPR
+            SMAX = SMAXPR
+            RANK = RANK + 1
+            GO TO 10
+         END IF
+      END IF
+*
+*     complex workspace: 3*MN.
+*
+*     Logically partition R = [ R11 R12 ]
+*                             [  0  R22 ]
+*     where R11 = R(1:RANK,1:RANK)
+*
+*     [R11,R12] = [ T11, 0 ] * Y
+*
+      IF( RANK.LT.N )
+     $   CALL ZTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
+     $                LWORK-2*MN, INFO )
+*
+*     complex workspace: 2*MN.
+*     Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+*     B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+      CALL ZUNMQR( 'Left', 'Conjugate transpose', M, NRHS, MN, A, LDA,
+     $             WORK( 1 ), B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+      WSIZE = MAX( WSIZE, 2*MN+DBLE( WORK( 2*MN+1 ) ) )
+*
+*     complex workspace: 2*MN+NB*NRHS.
+*
+*     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+      CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+     $            NRHS, CONE, A, LDA, B, LDB )
+*
+      DO 40 J = 1, NRHS
+         DO 30 I = RANK + 1, N
+            B( I, J ) = CZERO
+   30    CONTINUE
+   40 CONTINUE
+*
+*     B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+      IF( RANK.LT.N ) THEN
+         CALL ZUNMRZ( 'Left', 'Conjugate transpose', N, NRHS, RANK,
+     $                N-RANK, A, LDA, WORK( MN+1 ), B, LDB,
+     $                WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+      END IF
+*
+*     complex workspace: 2*MN+NRHS.
+*
+*     B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+      DO 60 J = 1, NRHS
+         DO 50 I = 1, N
+            WORK( JPVT( I ) ) = B( I, J )
+   50    CONTINUE
+         CALL ZCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+   60 CONTINUE
+*
+*     complex workspace: N.
+*
+*     Undo scaling
+*
+      IF( IASCL.EQ.1 ) THEN
+         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+         CALL ZLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      ELSE IF( IASCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+         CALL ZLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+     $                INFO )
+      END IF
+      IF( IBSCL.EQ.1 ) THEN
+         CALL ZLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+      ELSE IF( IBSCL.EQ.2 ) THEN
+         CALL ZLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+      END IF
+*
+   70 CONTINUE
+      WORK( 1 ) = DCMPLX( LWKOPT )
+*
+      RETURN
+*
+*     End of ZGELSY
+*
+      END
diff --git a/src/lib/lapack/zgeqp3.f b/src/lib/lapack/zgeqp3.f
new file mode 100644
index 00000000..32bf3367
--- /dev/null
+++ b/src/lib/lapack/zgeqp3.f
@@ -0,0 +1,293 @@
+      SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK,
+     $                   INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEQP3 computes a QR factorization with column pivoting of a
+*  matrix A:  A*P = Q*R  using Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of the array contains the
+*          min(M,N)-by-N upper trapezoidal matrix R; the elements below
+*          the diagonal, together with the array TAU, represent the
+*          unitary matrix Q as a product of min(M,N) elementary
+*          reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(J)=0,
+*          the J-th column of A is a free column.
+*          On exit, if JPVT(J)=K, then the J-th column of A*P was the
+*          the K-th column of A.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= N+1.
+*          For optimal performance LWORK >= ( N+1 )*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit.
+*          < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a real/complex scalar, and v is a real/complex vector
+*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
+*  A(i+1:m,i), and tau in TAU(i).
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            INB, INBMIN, IXOVER
+      PARAMETER          ( INB = 1, INBMIN = 2, IXOVER = 3 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
+     $                   NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQRF, ZLAQP2, ZLAQPS, ZSWAP, ZUNMQR
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DZNRM2
+      EXTERNAL           ILAENV, DZNRM2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          INT, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test input arguments
+*     ====================
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         MINMN = MIN( M, N )
+         IF( MINMN.EQ.0 ) THEN
+            IWS = 1
+            LWKOPT = 1
+         ELSE
+            IWS = N + 1
+            NB = ILAENV( INB, 'ZGEQRF', ' ', M, N, -1, -1 )
+            LWKOPT = ( N + 1 )*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQP3', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( MINMN.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Move initial columns up front.
+*
+      NFXD = 1
+      DO 10 J = 1, N
+         IF( JPVT( J ).NE.0 ) THEN
+            IF( J.NE.NFXD ) THEN
+               CALL ZSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
+               JPVT( J ) = JPVT( NFXD )
+               JPVT( NFXD ) = J
+            ELSE
+               JPVT( J ) = J
+            END IF
+            NFXD = NFXD + 1
+         ELSE
+            JPVT( J ) = J
+         END IF
+   10 CONTINUE
+      NFXD = NFXD - 1
+*
+*     Factorize fixed columns
+*     =======================
+*
+*     Compute the QR factorization of fixed columns and update
+*     remaining columns.
+*
+      IF( NFXD.GT.0 ) THEN
+         NA = MIN( M, NFXD )
+*CC      CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+         CALL ZGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+         IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         IF( NA.LT.N ) THEN
+*CC         CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA,
+*CC  $                   NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK,
+*CC  $                   INFO )
+            CALL ZUNMQR( 'Left', 'Conjugate Transpose', M, N-NA, NA, A,
+     $                   LDA, TAU, A( 1, NA+1 ), LDA, WORK, LWORK,
+     $                   INFO )
+            IWS = MAX( IWS, INT( WORK( 1 ) ) )
+         END IF
+      END IF
+*
+*     Factorize free columns
+*     ======================
+*
+      IF( NFXD.LT.MINMN ) THEN
+*
+         SM = M - NFXD
+         SN = N - NFXD
+         SMINMN = MINMN - NFXD
+*
+*        Determine the block size.
+*
+         NB = ILAENV( INB, 'ZGEQRF', ' ', SM, SN, -1, -1 )
+         NBMIN = 2
+         NX = 0
+*
+         IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
+*
+*           Determine when to cross over from blocked to unblocked code.
+*
+            NX = MAX( 0, ILAENV( IXOVER, 'ZGEQRF', ' ', SM, SN, -1,
+     $           -1 ) )
+*
+*
+            IF( NX.LT.SMINMN ) THEN
+*
+*              Determine if workspace is large enough for blocked code.
+*
+               MINWS = ( SN+1 )*NB
+               IWS = MAX( IWS, MINWS )
+               IF( LWORK.LT.MINWS ) THEN
+*
+*                 Not enough workspace to use optimal NB: Reduce NB and
+*                 determine the minimum value of NB.
+*
+                  NB = LWORK / ( SN+1 )
+                  NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQRF', ' ', SM, SN,
+     $                    -1, -1 ) )
+*
+*
+               END IF
+            END IF
+         END IF
+*
+*        Initialize partial column norms. The first N elements of work
+*        store the exact column norms.
+*
+         DO 20 J = NFXD + 1, N
+            RWORK( J ) = DZNRM2( SM, A( NFXD+1, J ), 1 )
+            RWORK( N+J ) = RWORK( J )
+   20    CONTINUE
+*
+         IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
+     $       ( NX.LT.SMINMN ) ) THEN
+*
+*           Use blocked code initially.
+*
+            J = NFXD + 1
+*
+*           Compute factorization: while loop.
+*
+*
+            TOPBMN = MINMN - NX
+   30       CONTINUE
+            IF( J.LE.TOPBMN ) THEN
+               JB = MIN( NB, TOPBMN-J+1 )
+*
+*              Factorize JB columns among columns J:N.
+*
+               CALL ZLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
+     $                      JPVT( J ), TAU( J ), RWORK( J ),
+     $                      RWORK( N+J ), WORK( 1 ), WORK( JB+1 ),
+     $                      N-J+1 )
+*
+               J = J + FJB
+               GO TO 30
+            END IF
+         ELSE
+            J = NFXD + 1
+         END IF
+*
+*        Use unblocked code to factor the last or only block.
+*
+*
+         IF( J.LE.MINMN )
+     $      CALL ZLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
+     $                   TAU( J ), RWORK( J ), RWORK( N+J ), WORK( 1 ) )
+*
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGEQP3
+*
+      END
diff --git a/src/lib/lapack/zgeqpf.f b/src/lib/lapack/zgeqpf.f
new file mode 100644
index 00000000..6d4f86f0
--- /dev/null
+++ b/src/lib/lapack/zgeqpf.f
@@ -0,0 +1,234 @@
+      SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
+*
+*  -- LAPACK deprecated driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  This routine is deprecated and has been replaced by routine ZGEQP3.
+*
+*  ZGEQPF computes a QR factorization with column pivoting of a
+*  complex M-by-N matrix A: A*P = Q*R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of the array contains the
+*          min(M,N)-by-N upper triangular matrix R; the elements
+*          below the diagonal, together with the array TAU,
+*          represent the unitary matrix Q as a product of
+*          min(m,n) elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(i) = 0,
+*          the i-th column of A is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(n)
+*
+*  Each H(i) has the form
+*
+*     H = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
+*
+*  The matrix P is represented in jpvt as follows: If
+*     jpvt(j) = i
+*  then the jth column of P is the ith canonical unit vector.
+*
+*  Partial column norm updating strategy modified by
+*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+*    University of Zagreb, Croatia.
+*    June 2006.
+*  For more details see LAPACK Working Note 176.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MA, MN, PVT
+      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
+      COMPLEX*16         AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQR2, ZLARF, ZLARFG, ZSWAP, ZUNM2R
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCMPLX, DCONJG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQPF', -INFO )
+         RETURN
+      END IF
+*
+      MN = MIN( M, N )
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Move initial columns up front
+*
+      ITEMP = 1
+      DO 10 I = 1, N
+         IF( JPVT( I ).NE.0 ) THEN
+            IF( I.NE.ITEMP ) THEN
+               CALL ZSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+               JPVT( I ) = JPVT( ITEMP )
+               JPVT( ITEMP ) = I
+            ELSE
+               JPVT( I ) = I
+            END IF
+            ITEMP = ITEMP + 1
+         ELSE
+            JPVT( I ) = I
+         END IF
+   10 CONTINUE
+      ITEMP = ITEMP - 1
+*
+*     Compute the QR factorization and update remaining columns
+*
+      IF( ITEMP.GT.0 ) THEN
+         MA = MIN( ITEMP, M )
+         CALL ZGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+         IF( MA.LT.N ) THEN
+            CALL ZUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A,
+     $                   LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO )
+         END IF
+      END IF
+*
+      IF( ITEMP.LT.MN ) THEN
+*
+*        Initialize partial column norms. The first n elements of
+*        work store the exact column norms.
+*
+         DO 20 I = ITEMP + 1, N
+            RWORK( I ) = DZNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+            RWORK( N+I ) = RWORK( I )
+   20    CONTINUE
+*
+*        Compute factorization
+*
+         DO 40 I = ITEMP + 1, MN
+*
+*           Determine ith pivot column and swap if necessary
+*
+            PVT = ( I-1 ) + IDAMAX( N-I+1, RWORK( I ), 1 )
+*
+            IF( PVT.NE.I ) THEN
+               CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+               ITEMP = JPVT( PVT )
+               JPVT( PVT ) = JPVT( I )
+               JPVT( I ) = ITEMP
+               RWORK( PVT ) = RWORK( I )
+               RWORK( N+PVT ) = RWORK( N+I )
+            END IF
+*
+*           Generate elementary reflector H(i)
+*
+            AII = A( I, I )
+            CALL ZLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1,
+     $                   TAU( I ) )
+            A( I, I ) = AII
+*
+            IF( I.LT.N ) THEN
+*
+*              Apply H(i) to A(i:m,i+1:n) from the left
+*
+               AII = A( I, I )
+               A( I, I ) = DCMPLX( ONE )
+               CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                     DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
+               A( I, I ) = AII
+            END IF
+*
+*           Update partial column norms
+*
+            DO 30 J = I + 1, N
+               IF( RWORK( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following 4 lines follow from the analysis in
+*                 Lapack Working Note 176.
+*                 
+                  TEMP = ABS( A( I, J ) ) / RWORK( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN 
+                     IF( M-I.GT.0 ) THEN
+                        RWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 )
+                        RWORK( N+J ) = RWORK( J )
+                     ELSE
+                        RWORK( J ) = ZERO
+                        RWORK( N+J ) = ZERO
+                     END IF
+                  ELSE
+                     RWORK( J ) = RWORK( J )*SQRT( TEMP )
+                  END IF
+               END IF
+   30       CONTINUE
+*
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZGEQPF
+*
+      END
diff --git a/src/lib/lapack/zgeqr2.f b/src/lib/lapack/zgeqr2.f
new file mode 100644
index 00000000..962ab588
--- /dev/null
+++ b/src/lib/lapack/zgeqr2.f
@@ -0,0 +1,121 @@
+      SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEQR2 computes a QR factorization of a complex m by n matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(m,n) by n upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of elementary reflectors (see Further Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, K
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZLARFG
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQR2', -INFO )
+         RETURN
+      END IF
+*
+      K = MIN( M, N )
+*
+      DO 10 I = 1, K
+*
+*        Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+         CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+     $                TAU( I ) )
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i)' to A(i:m,i+1:n) from the left
+*
+            ALPHA = A( I, I )
+            A( I, I ) = ONE
+            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
+     $                  DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
+            A( I, I ) = ALPHA
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGEQR2
+*
+      END
diff --git a/src/lib/lapack/zgeqrf.f b/src/lib/lapack/zgeqrf.f
new file mode 100644
index 00000000..d11c9245
--- /dev/null
+++ b/src/lib/lapack/zgeqrf.f
@@ -0,0 +1,196 @@
+      SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
+*  A = Q * R.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the elements on and above the diagonal of the array
+*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is
+*          upper triangular if m >= n); the elements below the diagonal,
+*          with the array TAU, represent the unitary matrix Q as a
+*          product of min(m,n) elementary reflectors (see Further
+*          Details).
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+*  and tau in TAU(i).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEQR2, ZLARFB, ZLARFT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGEQRF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      K = MIN( M, N )
+      IF( K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZGEQRF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZGEQRF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code initially
+*
+         DO 10 I = 1, K - NX, NB
+            IB = MIN( K-I+1, NB )
+*
+*           Compute the QR factorization of the current block
+*           A(i:m,i:i+ib-1)
+*
+            CALL ZGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+            IF( I+IB.LE.N ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(i:m,i+ib:n) from the left
+*
+               CALL ZLARFB( 'Left', 'Conjugate transpose', 'Forward',
+     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
+     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+     $                      LDA, WORK( IB+1 ), LDWORK )
+            END IF
+   10    CONTINUE
+      ELSE
+         I = 1
+      END IF
+*
+*     Use unblocked code to factor the last or only block.
+*
+      IF( I.LE.K )
+     $   CALL ZGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+     $                IINFO )
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGEQRF
+*
+      END
diff --git a/src/lib/lapack/zgesc2.f b/src/lib/lapack/zgesc2.f
new file mode 100644
index 00000000..d4d51337
--- /dev/null
+++ b/src/lib/lapack/zgesc2.f
@@ -0,0 +1,133 @@
+      SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      COMPLEX*16         A( LDA, * ), RHS( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGESC2 solves a system of linear equations
+*
+*            A * X = scale* RHS
+*
+*  with a general N-by-N matrix A using the LU factorization with
+*  complete pivoting computed by ZGETC2.
+*
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the  LU part of the factorization of the n-by-n
+*          matrix A computed by ZGETC2:  A = P * L * U * Q
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1, N).
+*
+*  RHS     (input/output) COMPLEX*16 array, dimension N.
+*          On entry, the right hand side vector b.
+*          On exit, the solution vector X.
+*
+*  IPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  SCALE    (output) DOUBLE PRECISION
+*           On exit, SCALE contains the scale factor. SCALE is chosen
+*           0 <= SCALE <= 1 to prevent owerflow in the solution.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   BIGNUM, EPS, SMLNUM
+      COMPLEX*16         TEMP
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASWP, ZSCAL
+*     ..
+*     .. External Functions ..
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           IZAMAX, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constant to control overflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Apply permutations IPIV to RHS
+*
+      CALL ZLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
+*
+*     Solve for L part
+*
+      DO 20 I = 1, N - 1
+         DO 10 J = I + 1, N
+            RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
+   10    CONTINUE
+   20 CONTINUE
+*
+*     Solve for U part
+*
+      SCALE = ONE
+*
+*     Check for scaling
+*
+      I = IZAMAX( N, RHS, 1 )
+      IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+         TEMP = DCMPLX( ONE / TWO, ZERO ) / ABS( RHS( I ) )
+         CALL ZSCAL( N, TEMP, RHS( 1 ), 1 )
+         SCALE = SCALE*DBLE( TEMP )
+      END IF
+      DO 40 I = N, 1, -1
+         TEMP = DCMPLX( ONE, ZERO ) / A( I, I )
+         RHS( I ) = RHS( I )*TEMP
+         DO 30 J = I + 1, N
+            RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
+   30    CONTINUE
+   40 CONTINUE
+*
+*     Apply permutations JPIV to the solution (RHS)
+*
+      CALL ZLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+      RETURN
+*
+*     End of ZGESC2
+*
+      END
diff --git a/src/lib/lapack/zgesvd.f b/src/lib/lapack/zgesvd.f
new file mode 100644
index 00000000..7b238d8b
--- /dev/null
+++ b/src/lib/lapack/zgesvd.f
@@ -0,0 +1,3602 @@
+      SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+     $                   WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBU, JOBVT
+      INTEGER            INFO, LDA, LDU, LDVT, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), S( * )
+      COMPLEX*16         A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGESVD computes the singular value decomposition (SVD) of a complex
+*  M-by-N matrix A, optionally computing the left and/or right singular
+*  vectors. The SVD is written
+*
+*       A = U * SIGMA * conjugate-transpose(V)
+*
+*  where SIGMA is an M-by-N matrix which is zero except for its
+*  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
+*  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
+*  are the singular values of A; they are real and non-negative, and
+*  are returned in descending order.  The first min(m,n) columns of
+*  U and V are the left and right singular vectors of A.
+*
+*  Note that the routine returns V**H, not V.
+*
+*  Arguments
+*  =========
+*
+*  JOBU    (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix U:
+*          = 'A':  all M columns of U are returned in array U:
+*          = 'S':  the first min(m,n) columns of U (the left singular
+*                  vectors) are returned in the array U;
+*          = 'O':  the first min(m,n) columns of U (the left singular
+*                  vectors) are overwritten on the array A;
+*          = 'N':  no columns of U (no left singular vectors) are
+*                  computed.
+*
+*  JOBVT   (input) CHARACTER*1
+*          Specifies options for computing all or part of the matrix
+*          V**H:
+*          = 'A':  all N rows of V**H are returned in the array VT;
+*          = 'S':  the first min(m,n) rows of V**H (the right singular
+*                  vectors) are returned in the array VT;
+*          = 'O':  the first min(m,n) rows of V**H (the right singular
+*                  vectors) are overwritten on the array A;
+*          = 'N':  no rows of V**H (no right singular vectors) are
+*                  computed.
+*
+*          JOBVT and JOBU cannot both be 'O'.
+*
+*  M       (input) INTEGER
+*          The number of rows of the input matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the input matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit,
+*          if JOBU = 'O',  A is overwritten with the first min(m,n)
+*                          columns of U (the left singular vectors,
+*                          stored columnwise);
+*          if JOBVT = 'O', A is overwritten with the first min(m,n)
+*                          rows of V**H (the right singular vectors,
+*                          stored rowwise);
+*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
+*                          are destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))
+*          The singular values of A, sorted so that S(i) >= S(i+1).
+*
+*  U       (output) COMPLEX*16 array, dimension (LDU,UCOL)
+*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
+*          If JOBU = 'A', U contains the M-by-M unitary matrix U;
+*          if JOBU = 'S', U contains the first min(m,n) columns of U
+*          (the left singular vectors, stored columnwise);
+*          if JOBU = 'N' or 'O', U is not referenced.
+*
+*  LDU     (input) INTEGER
+*          The leading dimension of the array U.  LDU >= 1; if
+*          JOBU = 'S' or 'A', LDU >= M.
+*
+*  VT      (output) COMPLEX*16 array, dimension (LDVT,N)
+*          If JOBVT = 'A', VT contains the N-by-N unitary matrix
+*          V**H;
+*          if JOBVT = 'S', VT contains the first min(m,n) rows of
+*          V**H (the right singular vectors, stored rowwise);
+*          if JOBVT = 'N' or 'O', VT is not referenced.
+*
+*  LDVT    (input) INTEGER
+*          The leading dimension of the array VT.  LDVT >= 1; if
+*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          LWORK >=  MAX(1,2*MIN(M,N)+MAX(M,N)).
+*          For good performance, LWORK should generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))
+*          On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
+*          unconverged superdiagonal elements of an upper bidiagonal
+*          matrix B whose diagonal is in S (not necessarily sorted).
+*          B satisfies A = U * B * VT, so it has the same singular
+*          values as A, and singular vectors related by U and VT.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          > 0:  if ZBDSQR did not converge, INFO specifies how many
+*                superdiagonals of an intermediate bidiagonal form B
+*                did not converge to zero. See the description of RWORK
+*                above for details.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
+     $                   WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
+      INTEGER            BLK, CHUNK, I, IE, IERR, IR, IRWORK, ISCL,
+     $                   ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
+     $                   MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
+     $                   NRVT, WRKBL
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+      COMPLEX*16         CDUM( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLASCL, XERBLA, ZBDSQR, ZGEBRD, ZGELQF, ZGEMM,
+     $                   ZGEQRF, ZLACPY, ZLASCL, ZLASET, ZUNGBR, ZUNGLQ,
+     $                   ZUNGQR, ZUNMBR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      MINMN = MIN( M, N )
+      WNTUA = LSAME( JOBU, 'A' )
+      WNTUS = LSAME( JOBU, 'S' )
+      WNTUAS = WNTUA .OR. WNTUS
+      WNTUO = LSAME( JOBU, 'O' )
+      WNTUN = LSAME( JOBU, 'N' )
+      WNTVA = LSAME( JOBVT, 'A' )
+      WNTVS = LSAME( JOBVT, 'S' )
+      WNTVAS = WNTVA .OR. WNTVS
+      WNTVO = LSAME( JOBVT, 'O' )
+      WNTVN = LSAME( JOBVT, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
+     $         ( WNTVO .AND. WNTUO ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -6
+      ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
+         INFO = -9
+      ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
+     $         ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
+         INFO = -11
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       CWorkspace refers to complex workspace, and RWorkspace to
+*       real workspace. NB refers to the optimal block size for the
+*       immediately following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         MINWRK = 1
+         MAXWRK = 1
+         IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+*           Space needed for ZBDSQR is BDSPAC = 5*N
+*
+            MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
+            IF( M.GE.MNTHR ) THEN
+               IF( WNTUN ) THEN
+*
+*                 Path 1 (M much larger than N, JOBU='N')
+*
+                  MAXWRK = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*N+2*N*
+     $                     ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  IF( WNTVO .OR. WNTVAS )
+     $               MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $                        ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MINWRK = 3*N
+               ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+*                 Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+*                 Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = MAX( N*N+WRKBL, N*N+M*N )
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUS .AND. WNTVN ) THEN
+*
+*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUS .AND. WNTVO ) THEN
+*
+*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = 2*N*N + WRKBL
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUS .AND. WNTVAS ) THEN
+*
+*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUA .AND. WNTVN ) THEN
+*
+*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUA .AND. WNTVO ) THEN
+*
+*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = 2*N*N + WRKBL
+                  MINWRK = 2*N + M
+               ELSE IF( WNTUA .AND. WNTVAS ) THEN
+*
+*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
+*                 'A')
+*
+                  WRKBL = N + N*ILAENV( 1, 'ZGEQRF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'ZUNGQR', ' ', M,
+     $                    M, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+2*N*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', N, N, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+N*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', N, N, N, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*N+( N-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+                  MAXWRK = N*N + WRKBL
+                  MINWRK = 2*N + M
+               END IF
+            ELSE
+*
+*              Path 10 (M at least N, but not much larger)
+*
+               MAXWRK = 2*N + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTUS .OR. WNTUO )
+     $            MAXWRK = MAX( MAXWRK, 2*N+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, N, N, -1 ) )
+               IF( WNTUA )
+     $            MAXWRK = MAX( MAXWRK, 2*N+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, N, -1 ) )
+               IF( .NOT.WNTVN )
+     $            MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, N, -1 ) )
+               MINWRK = 2*N + M
+            END IF
+         ELSE IF( MINMN.GT.0 ) THEN
+*
+*           Space needed for ZBDSQR is BDSPAC = 5*M
+*
+            MNTHR = ILAENV( 6, 'ZGESVD', JOBU // JOBVT, M, N, 0, 0 )
+            IF( N.GE.MNTHR ) THEN
+               IF( WNTVN ) THEN
+*
+*                 Path 1t(N much larger than M, JOBVT='N')
+*
+                  MAXWRK = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1,
+     $                     -1 )
+                  MAXWRK = MAX( MAXWRK, 2*M+2*M*
+     $                     ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  IF( WNTUO .OR. WNTUAS )
+     $               MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                        ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MINWRK = 3*M
+               ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+*                 Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+*                 Path 3t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='O')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = MAX( M*M+WRKBL, M*M+M*N )
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVS .AND. WNTUN ) THEN
+*
+*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVS .AND. WNTUO ) THEN
+*
+*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = 2*M*M + WRKBL
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+*                 Path 6t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='S')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'ZUNGLQ', ' ', M,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVA .AND. WNTUN ) THEN
+*
+*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVA .AND. WNTUO ) THEN
+*
+*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = 2*M*M + WRKBL
+                  MINWRK = 2*M + N
+               ELSE IF( WNTVA .AND. WNTUAS ) THEN
+*
+*                 Path 9t(N much larger than M, JOBU='S' or 'A',
+*                 JOBVT='A')
+*
+                  WRKBL = M + M*ILAENV( 1, 'ZGELQF', ' ', M, N, -1, -1 )
+                  WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'ZUNGLQ', ' ', N,
+     $                    N, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+2*M*
+     $                    ILAENV( 1, 'ZGEBRD', ' ', M, M, -1, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+( M-1 )*
+     $                    ILAENV( 1, 'ZUNGBR', 'P', M, M, M, -1 ) )
+                  WRKBL = MAX( WRKBL, 2*M+M*
+     $                    ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+                  MAXWRK = M*M + WRKBL
+                  MINWRK = 2*M + N
+               END IF
+            ELSE
+*
+*              Path 10t(N greater than M, but not much larger)
+*
+               MAXWRK = 2*M + ( M+N )*ILAENV( 1, 'ZGEBRD', ' ', M, N,
+     $                  -1, -1 )
+               IF( WNTVS .OR. WNTVO )
+     $            MAXWRK = MAX( MAXWRK, 2*M+M*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', M, N, M, -1 ) )
+               IF( WNTVA )
+     $            MAXWRK = MAX( MAXWRK, 2*M+N*
+     $                     ILAENV( 1, 'ZUNGBR', 'P', N, N, M, -1 ) )
+               IF( .NOT.WNTUN )
+     $            MAXWRK = MAX( MAXWRK, 2*M+( M-1 )*
+     $                     ILAENV( 1, 'ZUNGBR', 'Q', M, M, M, -1 ) )
+               MINWRK = 2*M + N
+            END IF
+         END IF
+         MAXWRK = MAX( MAXWRK, MINWRK )
+         WORK( 1 ) = MAXWRK
+*
+         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGESVD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', M, N, A, LDA, DUM )
+      ISCL = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ISCL = 1
+         CALL ZLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ISCL = 1
+         CALL ZLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+      END IF
+*
+      IF( M.GE.N ) THEN
+*
+*        A has at least as many rows as columns. If A has sufficiently
+*        more rows than columns, first reduce using the QR
+*        decomposition (if sufficient workspace available)
+*
+         IF( M.GE.MNTHR ) THEN
+*
+            IF( WNTUN ) THEN
+*
+*              Path 1 (M much larger than N, JOBU='N')
+*              No left singular vectors to be computed
+*
+               ITAU = 1
+               IWORK = ITAU + N
+*
+*              Compute A=Q*R
+*              (CWorkspace: need 2*N, prefer N+N*NB)
+*              (RWorkspace: need 0)
+*
+               CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out below R
+*
+               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO, A( 2, 1 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = 1
+               ITAUP = ITAUQ + N
+               IWORK = ITAUP + N
+*
+*              Bidiagonalize R in A
+*              (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*              (RWorkspace: need N)
+*
+               CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                      IERR )
+               NCVT = 0
+               IF( WNTVO .OR. WNTVAS ) THEN
+*
+*                 If right singular vectors desired, generate P'.
+*                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  NCVT = N
+               END IF
+               IRWORK = IE + N
+*
+*              Perform bidiagonal QR iteration, computing right
+*              singular vectors of A in A if desired
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'U', N, NCVT, 0, 0, S, RWORK( IE ), A, LDA,
+     $                      CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
+*
+*              If right singular vectors desired in VT, copy them there
+*
+               IF( WNTVAS )
+     $            CALL ZLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+            ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+*              Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*              N left singular vectors to be overwritten on A and
+*              no right singular vectors to be computed
+*
+               IF( LWORK.GE.N*N+3*N ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
+*
+*                    WORK(IU) is LDA by N, WORK(IR) is LDA by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
+*
+*                    WORK(IU) is LDA by N, WORK(IR) is N by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = N
+                  ELSE
+*
+*                    WORK(IU) is LDWRKU by N, WORK(IR) is N by N
+*
+                     LDWRKU = ( LWORK-N*N ) / N
+                     LDWRKR = N
+                  END IF
+                  ITAU = IR + LDWRKR*N
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to WORK(IR) and zero out below it
+*
+                  CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                         WORK( IR+1 ), LDWRKR )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in WORK(IR)
+*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                 (RWorkspace: need N)
+*
+                  CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing R
+*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                 (RWorkspace: need 0)
+*
+                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUQ ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+                  IRWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of R in WORK(IR)
+*                 (CWorkspace: need N*N)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM, 1,
+     $                         WORK( IR ), LDWRKR, CDUM, 1,
+     $                         RWORK( IRWORK ), INFO )
+                  IU = ITAUQ
+*
+*                 Multiply Q in A by left singular vectors of R in
+*                 WORK(IR), storing result in WORK(IU) and copying to A
+*                 (CWorkspace: need N*N+N, prefer N*N+M*N)
+*                 (RWorkspace: 0)
+*
+                  DO 10 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   10             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  IE = 1
+                  ITAUQ = 1
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize A
+*                 (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
+*                 (RWorkspace: N)
+*
+                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing A
+*                 (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in A
+*                 (CWorkspace: need 0)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM, 1,
+     $                         A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+*              Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
+*              N left singular vectors to be overwritten on A and
+*              N right singular vectors to be computed in VT
+*
+               IF( LWORK.GE.N*N+3*N ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*N ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+N*N ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                     LDWRKU = LDA
+                     LDWRKR = N
+                  ELSE
+*
+*                    WORK(IU) is LDWRKU by N and WORK(IR) is N by N
+*
+                     LDWRKU = ( LWORK-N*N ) / N
+                     LDWRKR = N
+                  END IF
+                  ITAU = IR + LDWRKR*N
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            VT( 2, 1 ), LDVT )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in VT, copying result to WORK(IR)
+*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                 (RWorkspace: need N)
+*
+                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL ZLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
+*
+*                 Generate left vectors bidiagonalizing R in WORK(IR)
+*                 (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUQ ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing R in VT
+*                 (CWorkspace: need N*N+3*N-1, prefer N*N+2*N+(N-1)*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of R in WORK(IR) and computing right
+*                 singular vectors of R in VT
+*                 (CWorkspace: need N*N)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
+     $                         LDVT, WORK( IR ), LDWRKR, CDUM, 1,
+     $                         RWORK( IRWORK ), INFO )
+                  IU = ITAUQ
+*
+*                 Multiply Q in A by left singular vectors of R in
+*                 WORK(IR), storing result in WORK(IU) and copying to A
+*                 (CWorkspace: need N*N+N, prefer N*N+M*N)
+*                 (RWorkspace: 0)
+*
+                  DO 20 I = 1, M, LDWRKU
+                     CHUNK = MIN( M-I+1, LDWRKU )
+                     CALL ZGEMM( 'N', 'N', CHUNK, N, N, CONE, A( I, 1 ),
+     $                           LDA, WORK( IR ), LDWRKR, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL ZLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+     $                            A( I, 1 ), LDA )
+   20             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  ITAU = 1
+                  IWORK = ITAU + N
+*
+*                 Compute A=Q*R
+*                 (CWorkspace: need 2*N, prefer N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy R to VT, zeroing out below it
+*
+                  CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                  IF( N.GT.1 )
+     $               CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            VT( 2, 1 ), LDVT )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need 2*N, prefer N+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + N
+                  IWORK = ITAUP + N
+*
+*                 Bidiagonalize R in VT
+*                 (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                 (RWorkspace: N)
+*
+                  CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Multiply Q in A by left vectors bidiagonalizing R
+*                 (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                         WORK( ITAUQ ), A, LDA, WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing R in VT
+*                 (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + N
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in A and computing right
+*                 singular vectors of A in VT
+*                 (CWorkspace: 0)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
+     $                         LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
+     $                         INFO )
+*
+               END IF
+*
+            ELSE IF( WNTUS ) THEN
+*
+               IF( WNTVN ) THEN
+*
+*                 Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*                 N left singular vectors to be computed in U and
+*                 no right singular vectors to be computed
+*
+                  IF( LWORK.GE.N*N+3*N ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IR) is LDA by N
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is N by N
+*
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IR+1 ), LDWRKR )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IR)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left vectors bidiagonalizing R in WORK(IR)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IR)
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
+     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IR), storing result in U
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
+     $                           WORK( IR ), LDWRKR, CZERO, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            A( 2, 1 ), LDA )
+*
+*                    Bidiagonalize R in A
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left vectors bidiagonalizing R
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
+     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVO ) THEN
+*
+*                 Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*                 N left singular vectors to be computed in U and
+*                 N right singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*N*N+3*N ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     ELSE
+*
+*                       WORK(IU) is N by N and WORK(IR) is N by N
+*
+                        LDWRKU = N
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (CWorkspace: need   2*N*N+3*N,
+*                                 prefer 2*N*N+2*N+2*N*NB)
+*                    (RWorkspace: need   N)
+*
+                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need   2*N*N+3*N-1,
+*                                 prefer 2*N*N+2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in WORK(IR)
+*                    (CWorkspace: need 2*N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
+     $                            WORK( IR ), LDWRKR, WORK( IU ),
+     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IU), storing result in U
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
+     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
+*
+*                    Copy right singular vectors of R to A
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            A( 2, 1 ), LDA )
+*
+*                    Bidiagonalize R in A
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left vectors bidiagonalizing R
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right vectors bidiagonalizing R in A
+*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in A
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
+     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVAS ) THEN
+*
+*                 Path 6 (M much larger than N, JOBU='S', JOBVT='S'
+*                         or 'A')
+*                 N left singular vectors to be computed in U and
+*                 N right singular vectors to be computed in VT
+*
+                  IF( LWORK.GE.N*N+3*N ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is N by N
+*
+                        LDWRKU = N
+                     END IF
+                     ITAU = IU + LDWRKU*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to VT
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+     $                            LDVT )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (CWorkspace: need   N*N+3*N-1,
+*                                 prefer N*N+2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in VT
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
+     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply Q in A by left singular vectors of R in
+*                    WORK(IU), storing result in U
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, A, LDA,
+     $                           WORK( IU ), LDWRKU, CZERO, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, N, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to VT, zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                               VT( 2, 1 ), LDVT )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in VT
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in VT
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               END IF
+*
+            ELSE IF( WNTUA ) THEN
+*
+               IF( WNTVN ) THEN
+*
+*                 Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*                 M left singular vectors to be computed in U and
+*                 no right singular vectors to be computed
+*
+                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IR) is LDA by N
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is N by N
+*
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Copy R to WORK(IR), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IR+1 ), LDWRKR )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IR)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, WORK( IR ), LDWRKR, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IR)
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, 0, N, 0, S, RWORK( IE ), CDUM,
+     $                            1, WORK( IR ), LDWRKR, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IR), storing result in A
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
+     $                           WORK( IR ), LDWRKR, CZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            A( 2, 1 ), LDA )
+*
+*                    Bidiagonalize R in A
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in A
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, 0, M, 0, S, RWORK( IE ), CDUM,
+     $                            1, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVO ) THEN
+*
+*                 Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*                 M left singular vectors to be computed in U and
+*                 N right singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*N*N+MAX( N+M, 3*N ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+*                       WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     ELSE
+*
+*                       WORK(IU) is N by N and WORK(IR) is N by N
+*
+                        LDWRKU = N
+                        IR = IU + LDWRKU*N
+                        LDWRKR = N
+                     END IF
+                     ITAU = IR + LDWRKR*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (CWorkspace: need   2*N*N+3*N,
+*                                 prefer 2*N*N+2*N+2*N*NB)
+*                    (RWorkspace: need   N)
+*
+                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need   2*N*N+3*N-1,
+*                                 prefer 2*N*N+2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in WORK(IR)
+*                    (CWorkspace: need 2*N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ),
+     $                            WORK( IR ), LDWRKR, WORK( IU ),
+     $                            LDWRKU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IU), storing result in A
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
+     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+*                    Copy right singular vectors of R from WORK(IR) to A
+*
+                     CALL ZLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Zero out below R in A
+*
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            A( 2, 1 ), LDA )
+*
+*                    Bidiagonalize R in A
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in A
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in A
+*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in A
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), A,
+     $                            LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTVAS ) THEN
+*
+*                 Path 9 (M much larger than N, JOBU='A', JOBVT='S'
+*                         or 'A')
+*                 M left singular vectors to be computed in U and
+*                 N right singular vectors to be computed in VT
+*
+                  IF( LWORK.GE.N*N+MAX( N+M, 3*N ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is N by N
+*
+                        LDWRKU = N
+                     END IF
+                     ITAU = IU + LDWRKU*N
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need N*N+2*N, prefer N*N+N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N*N+N+M, prefer N*N+N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R to WORK(IU), zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                            WORK( IU+1 ), LDWRKU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in WORK(IU), copying result to VT
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+     $                            LDVT )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (CWorkspace: need   N*N+3*N-1,
+*                                 prefer N*N+2*N+(N-1)*NB)
+*                    (RWorkspace: need   0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of R in WORK(IU) and computing
+*                    right singular vectors of R in VT
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, N, 0, S, RWORK( IE ), VT,
+     $                            LDVT, WORK( IU ), LDWRKU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply Q in U by left singular vectors of R in
+*                    WORK(IU), storing result in A
+*                    (CWorkspace: need N*N)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, N, CONE, U, LDU,
+     $                           WORK( IU ), LDWRKU, CZERO, A, LDA )
+*
+*                    Copy left singular vectors of A from A to U
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + N
+*
+*                    Compute A=Q*R, copying result to U
+*                    (CWorkspace: need 2*N, prefer N+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEQRF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+*                    Generate Q in U
+*                    (CWorkspace: need N+M, prefer N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGQR( M, M, N, U, LDU, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy R from A to VT, zeroing out below it
+*
+                     CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+                     IF( N.GT.1 )
+     $                  CALL ZLASET( 'L', N-1, N-1, CZERO, CZERO,
+     $                               VT( 2, 1 ), LDVT )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + N
+                     IWORK = ITAUP + N
+*
+*                    Bidiagonalize R in VT
+*                    (CWorkspace: need 3*N, prefer 2*N+2*N*NB)
+*                    (RWorkspace: need N)
+*
+                     CALL ZGEBRD( N, N, VT, LDVT, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply Q in U by left bidiagonalizing vectors
+*                    in VT
+*                    (CWorkspace: need 2*N+M, prefer 2*N+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+     $                            WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in VT
+*                    (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + N
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', N, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               END IF
+*
+            END IF
+*
+         ELSE
+*
+*           M .LT. MNTHR
+*
+*           Path 10 (M at least N, but not much larger)
+*           Reduce to bidiagonal form without QR decomposition
+*
+            IE = 1
+            ITAUQ = 1
+            ITAUP = ITAUQ + N
+            IWORK = ITAUP + N
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*N+M, prefer 2*N+(M+N)*NB)
+*           (RWorkspace: need N)
+*
+            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                   IERR )
+            IF( WNTUAS ) THEN
+*
+*              If left singular vectors desired in U, copy result to U
+*              and generate left bidiagonalizing vectors in U
+*              (CWorkspace: need 2*N+NCU, prefer 2*N+NCU*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'L', M, N, A, LDA, U, LDU )
+               IF( WNTUS )
+     $            NCU = N
+               IF( WNTUA )
+     $            NCU = M
+               CALL ZUNGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVAS ) THEN
+*
+*              If right singular vectors desired in VT, copy result to
+*              VT and generate right bidiagonalizing vectors in VT
+*              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'U', N, N, A, LDA, VT, LDVT )
+               CALL ZUNGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTUO ) THEN
+*
+*              If left singular vectors desired in A, generate left
+*              bidiagonalizing vectors in A
+*              (CWorkspace: need 3*N, prefer 2*N+N*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVO ) THEN
+*
+*              If right singular vectors desired in A, generate right
+*              bidiagonalizing vectors in A
+*              (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IRWORK = IE + N
+            IF( WNTUAS .OR. WNTUO )
+     $         NRU = M
+            IF( WNTUN )
+     $         NRU = 0
+            IF( WNTVAS .OR. WNTVO )
+     $         NCVT = N
+            IF( WNTVN )
+     $         NCVT = 0
+            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in VT
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
+     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in A
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), A,
+     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            ELSE
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in A and computing right singular
+*              vectors in VT
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'U', N, NCVT, NRU, 0, S, RWORK( IE ), VT,
+     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            END IF
+*
+         END IF
+*
+      ELSE
+*
+*        A has more columns than rows. If A has sufficiently more
+*        columns than rows, first reduce using the LQ decomposition (if
+*        sufficient workspace available)
+*
+         IF( N.GE.MNTHR ) THEN
+*
+            IF( WNTVN ) THEN
+*
+*              Path 1t(N much larger than M, JOBVT='N')
+*              No right singular vectors to be computed
+*
+               ITAU = 1
+               IWORK = ITAU + M
+*
+*              Compute A=L*Q
+*              (CWorkspace: need 2*M, prefer M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+     $                      LWORK-IWORK+1, IERR )
+*
+*              Zero out above L
+*
+               CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, A( 1, 2 ),
+     $                      LDA )
+               IE = 1
+               ITAUQ = 1
+               ITAUP = ITAUQ + M
+               IWORK = ITAUP + M
+*
+*              Bidiagonalize L in A
+*              (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*              (RWorkspace: need M)
+*
+               CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                      WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                      IERR )
+               IF( WNTUO .OR. WNTUAS ) THEN
+*
+*                 If left singular vectors desired, generate Q
+*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+               END IF
+               IRWORK = IE + M
+               NRU = 0
+               IF( WNTUO .OR. WNTUAS )
+     $            NRU = M
+*
+*              Perform bidiagonal QR iteration, computing left singular
+*              vectors of A in A if desired
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'U', M, 0, NRU, 0, S, RWORK( IE ), CDUM, 1,
+     $                      A, LDA, CDUM, 1, RWORK( IRWORK ), INFO )
+*
+*              If left singular vectors desired in U, copy them there
+*
+               IF( WNTUAS )
+     $            CALL ZLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+            ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+*              Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*              M right singular vectors to be overwritten on A and
+*              no left singular vectors to be computed
+*
+               IF( LWORK.GE.M*M+3*M ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = M
+                  ELSE
+*
+*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+                     LDWRKU = M
+                     CHUNK = ( LWORK-M*M ) / M
+                     LDWRKR = M
+                  END IF
+                  ITAU = IR + LDWRKR*M
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to WORK(IR) and zero out above it
+*
+                  CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                         WORK( IR+LDWRKR ), LDWRKR )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in WORK(IR)
+*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                 (RWorkspace: need M)
+*
+                  CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing L
+*                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUP ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+                  IRWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing right
+*                 singular vectors of L in WORK(IR)
+*                 (CWorkspace: need M*M)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
+     $                         WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
+     $                         RWORK( IRWORK ), INFO )
+                  IU = ITAUQ
+*
+*                 Multiply right singular vectors of L in WORK(IR) by Q
+*                 in A, storing result in WORK(IU) and copying to A
+*                 (CWorkspace: need M*M+M, prefer M*M+M*N)
+*                 (RWorkspace: 0)
+*
+                  DO 30 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+     $                            A( 1, I ), LDA )
+   30             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  IE = 1
+                  ITAUQ = 1
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize A
+*                 (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*                 (RWorkspace: need M)
+*
+                  CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Generate right vectors bidiagonalizing A
+*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing right
+*                 singular vectors of A in A
+*                 (CWorkspace: 0)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'L', M, N, 0, 0, S, RWORK( IE ), A, LDA,
+     $                         CDUM, 1, CDUM, 1, RWORK( IRWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+*              Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
+*              M right singular vectors to be overwritten on A and
+*              M left singular vectors to be computed in U
+*
+               IF( LWORK.GE.M*M+3*M ) THEN
+*
+*                 Sufficient workspace for a fast algorithm
+*
+                  IR = 1
+                  IF( LWORK.GE.MAX( WRKBL, LDA*N )+LDA*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = LDA
+                  ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N )+M*M ) THEN
+*
+*                    WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+                     LDWRKU = LDA
+                     CHUNK = N
+                     LDWRKR = M
+                  ELSE
+*
+*                    WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+                     LDWRKU = M
+                     CHUNK = ( LWORK-M*M ) / M
+                     LDWRKR = M
+                  END IF
+                  ITAU = IR + LDWRKR*M
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing about above it
+*
+                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
+     $                         LDU )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in U, copying result to WORK(IR)
+*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                 (RWorkspace: need M)
+*
+                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  CALL ZLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
+*
+*                 Generate right vectors bidiagonalizing L in WORK(IR)
+*                 (CWorkspace: need M*M+3*M-1, prefer M*M+2*M+(M-1)*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                         WORK( ITAUP ), WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing L in U
+*                 (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of L in U, and computing right
+*                 singular vectors of L in WORK(IR)
+*                 (CWorkspace: need M*M)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
+     $                         WORK( IR ), LDWRKR, U, LDU, CDUM, 1,
+     $                         RWORK( IRWORK ), INFO )
+                  IU = ITAUQ
+*
+*                 Multiply right singular vectors of L in WORK(IR) by Q
+*                 in A, storing result in WORK(IU) and copying to A
+*                 (CWorkspace: need M*M+M, prefer M*M+M*N))
+*                 (RWorkspace: 0)
+*
+                  DO 40 I = 1, N, CHUNK
+                     BLK = MIN( N-I+1, CHUNK )
+                     CALL ZGEMM( 'N', 'N', M, BLK, M, CONE, WORK( IR ),
+     $                           LDWRKR, A( 1, I ), LDA, CZERO,
+     $                           WORK( IU ), LDWRKU )
+                     CALL ZLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+     $                            A( 1, I ), LDA )
+   40             CONTINUE
+*
+               ELSE
+*
+*                 Insufficient workspace for a fast algorithm
+*
+                  ITAU = 1
+                  IWORK = ITAU + M
+*
+*                 Compute A=L*Q
+*                 (CWorkspace: need 2*M, prefer M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Copy L to U, zeroing out above it
+*
+                  CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+                  CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO, U( 1, 2 ),
+     $                         LDU )
+*
+*                 Generate Q in A
+*                 (CWorkspace: need 2*M, prefer M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IE = 1
+                  ITAUQ = ITAU
+                  ITAUP = ITAUQ + M
+                  IWORK = ITAUP + M
+*
+*                 Bidiagonalize L in U
+*                 (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                 (RWorkspace: need M)
+*
+                  CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
+     $                         WORK( ITAUQ ), WORK( ITAUP ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                 Multiply right vectors bidiagonalizing L by Q in A
+*                 (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
+     $                         WORK( ITAUP ), A, LDA, WORK( IWORK ),
+     $                         LWORK-IWORK+1, IERR )
+*
+*                 Generate left vectors bidiagonalizing L in U
+*                 (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                 (RWorkspace: 0)
+*
+                  CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                         WORK( IWORK ), LWORK-IWORK+1, IERR )
+                  IRWORK = IE + M
+*
+*                 Perform bidiagonal QR iteration, computing left
+*                 singular vectors of A in U and computing right
+*                 singular vectors of A in A
+*                 (CWorkspace: 0)
+*                 (RWorkspace: need BDSPAC)
+*
+                  CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), A, LDA,
+     $                         U, LDU, CDUM, 1, RWORK( IRWORK ), INFO )
+*
+               END IF
+*
+            ELSE IF( WNTVS ) THEN
+*
+               IF( WNTUN ) THEN
+*
+*                 Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 no left singular vectors to be computed
+*
+                  IF( LWORK.GE.M*M+3*M ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IR) is LDA by M
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is M by M
+*
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IR+LDWRKR ), LDWRKR )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IR)
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right vectors bidiagonalizing L in
+*                    WORK(IR)
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of L in WORK(IR)
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
+     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IR) by
+*                    Q in A, storing result in VT
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
+     $                           LDWRKR, A, LDA, CZERO, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy result to VT
+*
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            A( 1, 2 ), LDA )
+*
+*                    Bidiagonalize L in A
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right vectors bidiagonalizing L by Q in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
+     $                            LDVT, CDUM, 1, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUO ) THEN
+*
+*                 Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 M left singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*M*M+3*M ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     ELSE
+*
+*                       WORK(IU) is M by M and WORK(IR) is M by M
+*
+                        LDWRKU = M
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out below it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (CWorkspace: need   2*M*M+3*M,
+*                                 prefer 2*M*M+2*M+2*M*NB)
+*                    (RWorkspace: need   M)
+*
+                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need   2*M*M+3*M-1,
+*                                 prefer 2*M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in WORK(IR) and computing
+*                    right singular vectors of L in WORK(IU)
+*                    (CWorkspace: need 2*M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
+     $                            WORK( IU ), LDWRKU, WORK( IR ),
+     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in A, storing result in VT
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
+     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
+*
+*                    Copy left singular vectors of L to A
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            A( 1, 2 ), LDA )
+*
+*                    Bidiagonalize L in A
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right vectors bidiagonalizing L by Q in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors of L in A
+*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in A and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, A, LDA, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUAS ) THEN
+*
+*                 Path 6t(N much larger than M, JOBU='S' or 'A',
+*                         JOBVT='S')
+*                 M right singular vectors to be computed in VT and
+*                 M left singular vectors to be computed in U
+*
+                  IF( LWORK.GE.M*M+3*M ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by N
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is LDA by M
+*
+                        LDWRKU = M
+                     END IF
+                     ITAU = IU + LDWRKU*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+*
+*                    Generate Q in A
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to U
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+     $                            LDU )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need   M*M+3*M-1,
+*                                 prefer M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in U and computing right
+*                    singular vectors of L in WORK(IU)
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
+     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in A, storing result in VT
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
+     $                           LDWRKU, A, LDA, CZERO, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            U( 1, 2 ), LDU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in U
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in U by Q
+*                    in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               END IF
+*
+            ELSE IF( WNTVA ) THEN
+*
+               IF( WNTUN ) THEN
+*
+*                 Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 no left singular vectors to be computed
+*
+                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IR = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IR) is LDA by M
+*
+                        LDWRKR = LDA
+                     ELSE
+*
+*                       WORK(IR) is M by M
+*
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy L to WORK(IR), zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IR ),
+     $                            LDWRKR )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IR+LDWRKR ), LDWRKR )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IR)
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, WORK( IR ), LDWRKR, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need   M*M+3*M-1,
+*                                 prefer M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of L in WORK(IR)
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, 0, 0, S, RWORK( IE ),
+     $                            WORK( IR ), LDWRKR, CDUM, 1, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IR) by
+*                    Q in VT, storing result in A
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IR ),
+     $                           LDWRKR, VT, LDVT, CZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            A( 1, 2 ), LDA )
+*
+*                    Bidiagonalize L in A
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in A by Q
+*                    in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, 0, 0, S, RWORK( IE ), VT,
+     $                            LDVT, CDUM, 1, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUO ) THEN
+*
+*                 Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 M left singular vectors to be overwritten on A
+*
+                  IF( LWORK.GE.2*M*M+MAX( N+M, 3*M ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = LDA
+                     ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+*                       WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+                        LDWRKU = LDA
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     ELSE
+*
+*                       WORK(IU) is M by M and WORK(IR) is M by M
+*
+                        LDWRKU = M
+                        IR = IU + LDWRKU*M
+                        LDWRKR = M
+                     END IF
+                     ITAU = IR + LDWRKR*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to
+*                    WORK(IR)
+*                    (CWorkspace: need   2*M*M+3*M,
+*                                 prefer 2*M*M+2*M+2*M*NB)
+*                    (RWorkspace: need   M)
+*
+                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+     $                            WORK( IR ), LDWRKR )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need   2*M*M+3*M-1,
+*                                 prefer 2*M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in WORK(IR)
+*                    (CWorkspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+     $                            WORK( ITAUQ ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in WORK(IR) and computing
+*                    right singular vectors of L in WORK(IU)
+*                    (CWorkspace: need 2*M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
+     $                            WORK( IU ), LDWRKU, WORK( IR ),
+     $                            LDWRKR, CDUM, 1, RWORK( IRWORK ),
+     $                            INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in VT, storing result in A
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
+     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+*                    Copy left singular vectors of A from WORK(IR) to A
+*
+                     CALL ZLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+     $                            LDA )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Zero out above L in A
+*
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            A( 1, 2 ), LDA )
+*
+*                    Bidiagonalize L in A
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, A, LDA, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in A by Q
+*                    in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, A, LDA,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in A
+*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in A and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, A, LDA, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               ELSE IF( WNTUAS ) THEN
+*
+*                 Path 9t(N much larger than M, JOBU='S' or 'A',
+*                         JOBVT='A')
+*                 N right singular vectors to be computed in VT and
+*                 M left singular vectors to be computed in U
+*
+                  IF( LWORK.GE.M*M+MAX( N+M, 3*M ) ) THEN
+*
+*                    Sufficient workspace for a fast algorithm
+*
+                     IU = 1
+                     IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+*                       WORK(IU) is LDA by M
+*
+                        LDWRKU = LDA
+                     ELSE
+*
+*                       WORK(IU) is M by M
+*
+                        LDWRKU = M
+                     END IF
+                     ITAU = IU + LDWRKU*M
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need M*M+2*M, prefer M*M+M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M*M+M+N, prefer M*M+M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to WORK(IU), zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, WORK( IU ),
+     $                            LDWRKU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            WORK( IU+LDWRKU ), LDWRKU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in WORK(IU), copying result to U
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, WORK( IU ), LDWRKU, S,
+     $                            RWORK( IE ), WORK( ITAUQ ),
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+     $                            LDU )
+*
+*                    Generate right bidiagonalizing vectors in WORK(IU)
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+(M-1)*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+     $                            WORK( ITAUP ), WORK( IWORK ),
+     $                            LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (CWorkspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of L in U and computing right
+*                    singular vectors of L in WORK(IU)
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, M, M, 0, S, RWORK( IE ),
+     $                            WORK( IU ), LDWRKU, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+*                    Multiply right singular vectors of L in WORK(IU) by
+*                    Q in VT, storing result in A
+*                    (CWorkspace: need M*M)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGEMM( 'N', 'N', M, N, M, CONE, WORK( IU ),
+     $                           LDWRKU, VT, LDVT, CZERO, A, LDA )
+*
+*                    Copy right singular vectors of A from A to VT
+*
+                     CALL ZLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+                  ELSE
+*
+*                    Insufficient workspace for a fast algorithm
+*
+                     ITAU = 1
+                     IWORK = ITAU + M
+*
+*                    Compute A=L*Q, copying result to VT
+*                    (CWorkspace: need 2*M, prefer M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZGELQF( M, N, A, LDA, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+*                    Generate Q in VT
+*                    (CWorkspace: need M+N, prefer M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Copy L to U, zeroing out above it
+*
+                     CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+                     CALL ZLASET( 'U', M-1, M-1, CZERO, CZERO,
+     $                            U( 1, 2 ), LDU )
+                     IE = 1
+                     ITAUQ = ITAU
+                     ITAUP = ITAUQ + M
+                     IWORK = ITAUP + M
+*
+*                    Bidiagonalize L in U
+*                    (CWorkspace: need 3*M, prefer 2*M+2*M*NB)
+*                    (RWorkspace: need M)
+*
+                     CALL ZGEBRD( M, M, U, LDU, S, RWORK( IE ),
+     $                            WORK( ITAUQ ), WORK( ITAUP ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Multiply right bidiagonalizing vectors in U by Q
+*                    in VT
+*                    (CWorkspace: need 2*M+N, prefer 2*M+N*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNMBR( 'P', 'L', 'C', M, N, M, U, LDU,
+     $                            WORK( ITAUP ), VT, LDVT,
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+*                    Generate left bidiagonalizing vectors in U
+*                    (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*                    (RWorkspace: 0)
+*
+                     CALL ZUNGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+     $                            WORK( IWORK ), LWORK-IWORK+1, IERR )
+                     IRWORK = IE + M
+*
+*                    Perform bidiagonal QR iteration, computing left
+*                    singular vectors of A in U and computing right
+*                    singular vectors of A in VT
+*                    (CWorkspace: 0)
+*                    (RWorkspace: need BDSPAC)
+*
+                     CALL ZBDSQR( 'U', M, N, M, 0, S, RWORK( IE ), VT,
+     $                            LDVT, U, LDU, CDUM, 1,
+     $                            RWORK( IRWORK ), INFO )
+*
+                  END IF
+*
+               END IF
+*
+            END IF
+*
+         ELSE
+*
+*           N .LT. MNTHR
+*
+*           Path 10t(N greater than M, but not much larger)
+*           Reduce to bidiagonal form without LQ decomposition
+*
+            IE = 1
+            ITAUQ = 1
+            ITAUP = ITAUQ + M
+            IWORK = ITAUP + M
+*
+*           Bidiagonalize A
+*           (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB)
+*           (RWorkspace: M)
+*
+            CALL ZGEBRD( M, N, A, LDA, S, RWORK( IE ), WORK( ITAUQ ),
+     $                   WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+     $                   IERR )
+            IF( WNTUAS ) THEN
+*
+*              If left singular vectors desired in U, copy result to U
+*              and generate left bidiagonalizing vectors in U
+*              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'L', M, M, A, LDA, U, LDU )
+               CALL ZUNGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVAS ) THEN
+*
+*              If right singular vectors desired in VT, copy result to
+*              VT and generate right bidiagonalizing vectors in VT
+*              (CWorkspace: need 2*M+NRVT, prefer 2*M+NRVT*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZLACPY( 'U', M, N, A, LDA, VT, LDVT )
+               IF( WNTVA )
+     $            NRVT = N
+               IF( WNTVS )
+     $            NRVT = M
+               CALL ZUNGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTUO ) THEN
+*
+*              If left singular vectors desired in A, generate left
+*              bidiagonalizing vectors in A
+*              (CWorkspace: need 3*M-1, prefer 2*M+(M-1)*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IF( WNTVO ) THEN
+*
+*              If right singular vectors desired in A, generate right
+*              bidiagonalizing vectors in A
+*              (CWorkspace: need 3*M, prefer 2*M+M*NB)
+*              (RWorkspace: 0)
+*
+               CALL ZUNGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+     $                      WORK( IWORK ), LWORK-IWORK+1, IERR )
+            END IF
+            IRWORK = IE + M
+            IF( WNTUAS .OR. WNTUO )
+     $         NRU = M
+            IF( WNTUN )
+     $         NRU = 0
+            IF( WNTVAS .OR. WNTVO )
+     $         NCVT = N
+            IF( WNTVN )
+     $         NCVT = 0
+            IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in VT
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
+     $                      LDVT, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in U and computing right singular
+*              vectors in A
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), A,
+     $                      LDA, U, LDU, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            ELSE
+*
+*              Perform bidiagonal QR iteration, if desired, computing
+*              left singular vectors in A and computing right singular
+*              vectors in VT
+*              (CWorkspace: 0)
+*              (RWorkspace: need BDSPAC)
+*
+               CALL ZBDSQR( 'L', M, NCVT, NRU, 0, S, RWORK( IE ), VT,
+     $                      LDVT, A, LDA, CDUM, 1, RWORK( IRWORK ),
+     $                      INFO )
+            END IF
+*
+         END IF
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ISCL.EQ.1 ) THEN
+         IF( ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+     $      CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1,
+     $                   RWORK( IE ), MINMN, IERR )
+         IF( ANRM.LT.SMLNUM )
+     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+     $                   IERR )
+         IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+     $      CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1,
+     $                   RWORK( IE ), MINMN, IERR )
+      END IF
+*
+*     Return optimal workspace in WORK(1)
+*
+      WORK( 1 ) = MAXWRK
+*
+      RETURN
+*
+*     End of ZGESVD
+*
+      END
diff --git a/src/lib/lapack/zgetc2.f b/src/lib/lapack/zgetc2.f
new file mode 100644
index 00000000..35ac376c
--- /dev/null
+++ b/src/lib/lapack/zgetc2.f
@@ -0,0 +1,145 @@
+      SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGETC2 computes an LU factorization, using complete pivoting, of the
+*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,
+*  where P and Q are permutation matrices, L is lower triangular with
+*  unit diagonal elements and U is upper triangular.
+*
+*  This is a level 1 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the n-by-n matrix to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U*Q; the unit diagonal elements of L are not stored.
+*          If U(k, k) appears to be less than SMIN, U(k, k) is given the
+*          value of SMIN, giving a nonsingular perturbed system.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1, N).
+*
+*  IPIV    (output) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (output) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  INFO    (output) INTEGER
+*           = 0: successful exit
+*           > 0: if INFO = k, U(k, k) is likely to produce overflow if
+*                one tries to solve for x in Ax = b. So U is perturbed
+*                to avoid the overflow.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IP, IPV, J, JP, JPV
+      DOUBLE PRECISION   BIGNUM, EPS, SMIN, SMLNUM, XMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGERU, ZSWAP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCMPLX, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Set constants to control overflow
+*
+      INFO = 0
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+*
+*     Factorize A using complete pivoting.
+*     Set pivots less than SMIN to SMIN
+*
+      DO 40 I = 1, N - 1
+*
+*        Find max element in matrix A
+*
+         XMAX = ZERO
+         DO 20 IP = I, N
+            DO 10 JP = I, N
+               IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
+                  XMAX = ABS( A( IP, JP ) )
+                  IPV = IP
+                  JPV = JP
+               END IF
+   10       CONTINUE
+   20    CONTINUE
+         IF( I.EQ.1 )
+     $      SMIN = MAX( EPS*XMAX, SMLNUM )
+*
+*        Swap rows
+*
+         IF( IPV.NE.I )
+     $      CALL ZSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+         IPIV( I ) = IPV
+*
+*        Swap columns
+*
+         IF( JPV.NE.I )
+     $      CALL ZSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
+         JPIV( I ) = JPV
+*
+*        Check for singularity
+*
+         IF( ABS( A( I, I ) ).LT.SMIN ) THEN
+            INFO = I
+            A( I, I ) = DCMPLX( SMIN, ZERO )
+         END IF
+         DO 30 J = I + 1, N
+            A( J, I ) = A( J, I ) / A( I, I )
+   30    CONTINUE
+         CALL ZGERU( N-I, N-I, -DCMPLX( ONE ), A( I+1, I ), 1,
+     $               A( I, I+1 ), LDA, A( I+1, I+1 ), LDA )
+   40 CONTINUE
+*
+      IF( ABS( A( N, N ) ).LT.SMIN ) THEN
+         INFO = N
+         A( N, N ) = DCMPLX( SMIN, ZERO )
+      END IF
+      RETURN
+*
+*     End of ZGETC2
+*
+      END
diff --git a/src/lib/lapack/zgetf2.f b/src/lib/lapack/zgetf2.f
new file mode 100644
index 00000000..a2dc1834
--- /dev/null
+++ b/src/lib/lapack/zgetf2.f
@@ -0,0 +1,148 @@
+      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGETF2 computes an LU factorization of a general m-by-n matrix A
+*  using partial pivoting with row interchanges.
+*
+*  The factorization has the form
+*     A = P * L * U
+*  where P is a permutation matrix, L is lower triangular with unit
+*  diagonal elements (lower trapezoidal if m > n), and U is upper
+*  triangular (upper trapezoidal if m < n).
+*
+*  This is the right-looking Level 2 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  IPIV    (output) INTEGER array, dimension (min(M,N))
+*          The pivot indices; for 1 <= i <= min(M,N), row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+*               has been completed, but the factor U is exactly
+*               singular, and division by zero will occur if it is used
+*               to solve a system of equations.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   SFMIN
+      INTEGER            I, J, JP
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      INTEGER            IZAMAX
+      EXTERNAL           DLAMCH, IZAMAX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGETF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Compute machine safe minimum
+*
+      SFMIN = DLAMCH('S') 
+*
+      DO 10 J = 1, MIN( M, N )
+*
+*        Find pivot and test for singularity.
+*
+         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
+         IPIV( J ) = JP
+         IF( A( JP, J ).NE.ZERO ) THEN
+*
+*           Apply the interchange to columns 1:N.
+*
+            IF( JP.NE.J )
+     $         CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
+*
+*           Compute elements J+1:M of J-th column.
+*
+            IF( J.LT.M ) THEN
+               IF( ABS(A( J, J )) .GE. SFMIN ) THEN
+                  CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+               ELSE
+                  DO 20 I = 1, M-J
+                     A( J+I, J ) = A( J+I, J ) / A( J, J )
+   20             CONTINUE
+               END IF
+            END IF
+*
+         ELSE IF( INFO.EQ.0 ) THEN
+*
+            INFO = J
+         END IF
+*
+         IF( J.LT.MIN( M, N ) ) THEN
+*
+*           Update trailing submatrix.
+*
+            CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),
+     $                  LDA, A( J+1, J+1 ), LDA )
+         END IF
+   10 CONTINUE
+      RETURN
+*
+*     End of ZGETF2
+*
+      END
diff --git a/src/lib/lapack/zgetrf.f b/src/lib/lapack/zgetrf.f
new file mode 100644
index 00000000..9c7bfbbf
--- /dev/null
+++ b/src/lib/lapack/zgetrf.f
@@ -0,0 +1,159 @@
+      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGETRF computes an LU factorization of a general M-by-N matrix A
+*  using partial pivoting with row interchanges.
+*
+*  The factorization has the form
+*     A = P * L * U
+*  where P is a permutation matrix, L is lower triangular with unit
+*  diagonal elements (lower trapezoidal if m > n), and U is upper
+*  triangular (upper trapezoidal if m < n).
+*
+*  This is the right-looking Level 3 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix to be factored.
+*          On exit, the factors L and U from the factorization
+*          A = P*L*U; the unit diagonal elements of L are not stored.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  IPIV    (output) INTEGER array, dimension (min(M,N))
+*          The pivot indices; for 1 <= i <= min(M,N), row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
+*                has been completed, but the factor U is exactly
+*                singular, and division by zero will occur if it is used
+*                to solve a system of equations.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IINFO, J, JB, NB
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGETRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+*        Use unblocked code.
+*
+         CALL ZGETF2( M, N, A, LDA, IPIV, INFO )
+      ELSE
+*
+*        Use blocked code.
+*
+         DO 20 J = 1, MIN( M, N ), NB
+            JB = MIN( MIN( M, N )-J+1, NB )
+*
+*           Factor diagonal and subdiagonal blocks and test for exact
+*           singularity.
+*
+            CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
+*
+*           Adjust INFO and the pivot indices.
+*
+            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+     $         INFO = IINFO + J - 1
+            DO 10 I = J, MIN( M, J+JB-1 )
+               IPIV( I ) = J - 1 + IPIV( I )
+   10       CONTINUE
+*
+*           Apply interchanges to columns 1:J-1.
+*
+            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+            IF( J+JB.LE.N ) THEN
+*
+*              Apply interchanges to columns J+JB:N.
+*
+               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+     $                      IPIV, 1 )
+*
+*              Compute block row of U.
+*
+               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
+     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
+     $                     LDA )
+               IF( J+JB.LE.M ) THEN
+*
+*                 Update trailing submatrix.
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1,
+     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
+     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
+     $                        LDA )
+               END IF
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZGETRF
+*
+      END
diff --git a/src/lib/lapack/zgetri.f b/src/lib/lapack/zgetri.f
new file mode 100644
index 00000000..685518e6
--- /dev/null
+++ b/src/lib/lapack/zgetri.f
@@ -0,0 +1,193 @@
+      SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGETRI computes the inverse of a matrix using the LU factorization
+*  computed by ZGETRF.
+*
+*  This method inverts U and then computes inv(A) by solving the system
+*  inv(A)*L = inv(U) for inv(A).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the factors L and U from the factorization
+*          A = P*L*U as computed by ZGETRF.
+*          On exit, if INFO = 0, the inverse of the original matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*          For optimal performance LWORK >= N*NB, where NB is
+*          the optimal blocksize returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, U(i,i) is exactly zero; the matrix is
+*                singular and its inverse could not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZGEMV, ZSWAP, ZTRSM, ZTRTRI
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NB = ILAENV( 1, 'ZGETRI', ' ', N, -1, -1, -1 )
+      LWKOPT = N*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -3
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGETRI', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Form inv(U).  If INFO > 0 from ZTRTRI, then U is singular,
+*     and the inverse is not computed.
+*
+      CALL ZTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
+      IF( INFO.GT.0 )
+     $   RETURN
+*
+      NBMIN = 2
+      LDWORK = N
+      IF( NB.GT.1 .AND. NB.LT.N ) THEN
+         IWS = MAX( LDWORK*NB, 1 )
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'ZGETRI', ' ', N, -1, -1, -1 ) )
+         END IF
+      ELSE
+         IWS = N
+      END IF
+*
+*     Solve the equation inv(A)*L = inv(U) for inv(A).
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         DO 20 J = N, 1, -1
+*
+*           Copy current column of L to WORK and replace with zeros.
+*
+            DO 10 I = J + 1, N
+               WORK( I ) = A( I, J )
+               A( I, J ) = ZERO
+   10       CONTINUE
+*
+*           Compute current column of inv(A).
+*
+            IF( J.LT.N )
+     $         CALL ZGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
+     $                     LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
+   20    CONTINUE
+      ELSE
+*
+*        Use blocked code.
+*
+         NN = ( ( N-1 ) / NB )*NB + 1
+         DO 50 J = NN, 1, -NB
+            JB = MIN( NB, N-J+1 )
+*
+*           Copy current block column of L to WORK and replace with
+*           zeros.
+*
+            DO 40 JJ = J, J + JB - 1
+               DO 30 I = JJ + 1, N
+                  WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
+                  A( I, JJ ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+*
+*           Compute current block column of inv(A).
+*
+            IF( J+JB.LE.N )
+     $         CALL ZGEMM( 'No transpose', 'No transpose', N, JB,
+     $                     N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
+     $                     WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
+            CALL ZTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
+     $                  ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
+   50    CONTINUE
+      END IF
+*
+*     Apply column interchanges.
+*
+      DO 60 J = N - 1, 1, -1
+         JP = IPIV( J )
+         IF( JP.NE.J )
+     $      CALL ZSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+   60 CONTINUE
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZGETRI
+*
+      END
diff --git a/src/lib/lapack/zgetrs.f b/src/lib/lapack/zgetrs.f
new file mode 100644
index 00000000..e32549cd
--- /dev/null
+++ b/src/lib/lapack/zgetrs.f
@@ -0,0 +1,149 @@
+      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            INFO, LDA, LDB, N, NRHS
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGETRS solves a system of linear equations
+*     A * X = B,  A**T * X = B,  or  A**H * X = B
+*  with a general N-by-N matrix A using the LU factorization computed
+*  by ZGETRF.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the form of the system of equations:
+*          = 'N':  A * X = B     (No transpose)
+*          = 'T':  A**T * X = B  (Transpose)
+*          = 'C':  A**H * X = B  (Conjugate transpose)
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  NRHS    (input) INTEGER
+*          The number of right hand sides, i.e., the number of columns
+*          of the matrix B.  NRHS >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The factors L and U from the factorization A = P*L*U
+*          as computed by ZGETRF.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  IPIV    (input) INTEGER array, dimension (N)
+*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
+*          matrix was interchanged with row IPIV(i).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
+*          On entry, the right hand side matrix B.
+*          On exit, the solution matrix X.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLASWP, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $    LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( NRHS.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGETRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. NRHS.EQ.0 )
+     $   RETURN
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve A * X = B.
+*
+*        Apply row interchanges to the right hand sides.
+*
+         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+*        Solve L*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+     $               ONE, A, LDA, B, LDB )
+*
+*        Solve U*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+     $               NRHS, ONE, A, LDA, B, LDB )
+      ELSE
+*
+*        Solve A**T * X = B  or A**H * X = B.
+*
+*        Solve U'*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
+     $               A, LDA, B, LDB )
+*
+*        Solve L'*X = B, overwriting B with X.
+*
+         CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,
+     $               LDA, B, LDB )
+*
+*        Apply row interchanges to the solution vectors.
+*
+         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+      END IF
+*
+      RETURN
+*
+*     End of ZGETRS
+*
+      END
diff --git a/src/lib/lapack/zggbak.f b/src/lib/lapack/zggbak.f
new file mode 100644
index 00000000..ad6dd032
--- /dev/null
+++ b/src/lib/lapack/zggbak.f
@@ -0,0 +1,220 @@
+      SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
+     $                   LDV, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB, SIDE
+      INTEGER            IHI, ILO, INFO, LDV, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   LSCALE( * ), RSCALE( * )
+      COMPLEX*16         V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGBAK forms the right or left eigenvectors of a complex generalized
+*  eigenvalue problem A*x = lambda*B*x, by backward transformation on
+*  the computed eigenvectors of the balanced pair of matrices output by
+*  ZGGBAL.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the type of backward transformation required:
+*          = 'N':  do nothing, return immediately;
+*          = 'P':  do backward transformation for permutation only;
+*          = 'S':  do backward transformation for scaling only;
+*          = 'B':  do backward transformations for both permutation and
+*                  scaling.
+*          JOB must be the same as the argument JOB supplied to ZGGBAL.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  V contains right eigenvectors;
+*          = 'L':  V contains left eigenvectors.
+*
+*  N       (input) INTEGER
+*          The number of rows of the matrix V.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          The integers ILO and IHI determined by ZGGBAL.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  LSCALE  (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the left side of A and B, as returned by ZGGBAL.
+*
+*  RSCALE  (input) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and/or scaling factors applied
+*          to the right side of A and B, as returned by ZGGBAL.
+*
+*  M       (input) INTEGER
+*          The number of columns of the matrix V.  M >= 0.
+*
+*  V       (input/output) COMPLEX*16 array, dimension (LDV,M)
+*          On entry, the matrix of right or left eigenvectors to be
+*          transformed, as returned by ZTGEVC.
+*          On exit, V is overwritten by the transformed eigenvectors.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the matrix V. LDV >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  See R.C. Ward, Balancing the generalized eigenvalue problem,
+*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFTV, RIGHTV
+      INTEGER            I, K
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      RIGHTV = LSAME( SIDE, 'R' )
+      LEFTV = LSAME( SIDE, 'L' )
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
+         INFO = -4
+      ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
+     $   THEN
+         INFO = -5
+      ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
+         INFO = -5
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -8
+      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGBAK', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( M.EQ.0 )
+     $   RETURN
+      IF( LSAME( JOB, 'N' ) )
+     $   RETURN
+*
+      IF( ILO.EQ.IHI )
+     $   GO TO 30
+*
+*     Backward balance
+*
+      IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+*        Backward transformation on right eigenvectors
+*
+         IF( RIGHTV ) THEN
+            DO 10 I = ILO, IHI
+               CALL ZDSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
+   10       CONTINUE
+         END IF
+*
+*        Backward transformation on left eigenvectors
+*
+         IF( LEFTV ) THEN
+            DO 20 I = ILO, IHI
+               CALL ZDSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
+   20       CONTINUE
+         END IF
+      END IF
+*
+*     Backward permutation
+*
+   30 CONTINUE
+      IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+*        Backward permutation on right eigenvectors
+*
+         IF( RIGHTV ) THEN
+            IF( ILO.EQ.1 )
+     $         GO TO 50
+            DO 40 I = ILO - 1, 1, -1
+               K = RSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 40
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   40       CONTINUE
+*
+   50       CONTINUE
+            IF( IHI.EQ.N )
+     $         GO TO 70
+            DO 60 I = IHI + 1, N
+               K = RSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 60
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   60       CONTINUE
+         END IF
+*
+*        Backward permutation on left eigenvectors
+*
+   70    CONTINUE
+         IF( LEFTV ) THEN
+            IF( ILO.EQ.1 )
+     $         GO TO 90
+            DO 80 I = ILO - 1, 1, -1
+               K = LSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 80
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+   80       CONTINUE
+*
+   90       CONTINUE
+            IF( IHI.EQ.N )
+     $         GO TO 110
+            DO 100 I = IHI + 1, N
+               K = LSCALE( I )
+               IF( K.EQ.I )
+     $            GO TO 100
+               CALL ZSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+  100       CONTINUE
+         END IF
+      END IF
+*
+  110 CONTINUE
+*
+      RETURN
+*
+*     End of ZGGBAK
+*
+      END
diff --git a/src/lib/lapack/zggbal.f b/src/lib/lapack/zggbal.f
new file mode 100644
index 00000000..b75ae456
--- /dev/null
+++ b/src/lib/lapack/zggbal.f
@@ -0,0 +1,482 @@
+      SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
+     $                   RSCALE, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOB
+      INTEGER            IHI, ILO, INFO, LDA, LDB, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   LSCALE( * ), RSCALE( * ), WORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGBAL balances a pair of general complex matrices (A,B).  This
+*  involves, first, permuting A and B by similarity transformations to
+*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
+*  elements on the diagonal; and second, applying a diagonal similarity
+*  transformation to rows and columns ILO to IHI to make the rows
+*  and columns as close in norm as possible. Both steps are optional.
+*
+*  Balancing may reduce the 1-norm of the matrices, and improve the
+*  accuracy of the computed eigenvalues and/or eigenvectors in the
+*  generalized eigenvalue problem A*x = lambda*B*x.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies the operations to be performed on A and B:
+*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
+*                  and RSCALE(I) = 1.0 for i=1,...,N;
+*          = 'P':  permute only;
+*          = 'S':  scale only;
+*          = 'B':  both permute and scale.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the input matrix A.
+*          On exit, A is overwritten by the balanced matrix.
+*          If JOB = 'N', A is not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the input matrix B.
+*          On exit, B is overwritten by the balanced matrix.
+*          If JOB = 'N', B is not referenced.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  ILO     (output) INTEGER
+*  IHI     (output) INTEGER
+*          ILO and IHI are set to integers such that on exit
+*          A(i,j) = 0 and B(i,j) = 0 if i > j and
+*          j = 1,...,ILO-1 or i = IHI+1,...,N.
+*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the left side of A and B.  If P(j) is the index of the
+*          row interchanged with row j, and D(j) is the scaling factor
+*          applied to row j, then
+*            LSCALE(j) = P(j)    for J = 1,...,ILO-1
+*                      = D(j)    for J = ILO,...,IHI
+*                      = P(j)    for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)
+*          Details of the permutations and scaling factors applied
+*          to the right side of A and B.  If P(j) is the index of the
+*          column interchanged with column j, and D(j) is the scaling
+*          factor applied to column j, then
+*            RSCALE(j) = P(j)    for J = 1,...,ILO-1
+*                      = D(j)    for J = ILO,...,IHI
+*                      = P(j)    for J = IHI+1,...,N.
+*          The order in which the interchanges are made is N to IHI+1,
+*          then 1 to ILO-1.
+*
+*  WORK    (workspace) REAL array, dimension (lwork)
+*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
+*          at least 1 when JOB = 'N' or 'P'.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  See R.C. WARD, Balancing the generalized eigenvalue problem,
+*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   THREE, SCLFAC
+      PARAMETER          ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
+     $                   K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
+     $                   M, NR, NRP2
+      DOUBLE PRECISION   ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
+     $                   COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
+     $                   SFMIN, SUM, T, TA, TB, TC
+      COMPLEX*16         CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DDOT, DLAMCH
+      EXTERNAL           LSAME, IZAMAX, DDOT, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DAXPY, DSCAL, XERBLA, ZDSCAL, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+     $    .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGBAL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         ILO = 1
+         IHI = N
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         ILO = 1
+         IHI = N
+         LSCALE( 1 ) = ONE
+         RSCALE( 1 ) = ONE
+         RETURN
+      END IF
+*
+      IF( LSAME( JOB, 'N' ) ) THEN
+         ILO = 1
+         IHI = N
+         DO 10 I = 1, N
+            LSCALE( I ) = ONE
+            RSCALE( I ) = ONE
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      K = 1
+      L = N
+      IF( LSAME( JOB, 'S' ) )
+     $   GO TO 190
+*
+      GO TO 30
+*
+*     Permute the matrices A and B to isolate the eigenvalues.
+*
+*     Find row with one nonzero in columns 1 through L
+*
+   20 CONTINUE
+      L = LM1
+      IF( L.NE.1 )
+     $   GO TO 30
+*
+      RSCALE( 1 ) = 1
+      LSCALE( 1 ) = 1
+      GO TO 190
+*
+   30 CONTINUE
+      LM1 = L - 1
+      DO 80 I = L, 1, -1
+         DO 40 J = 1, LM1
+            JP1 = J + 1
+            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
+     $         GO TO 50
+   40    CONTINUE
+         J = L
+         GO TO 70
+*
+   50    CONTINUE
+         DO 60 J = JP1, L
+            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
+     $         GO TO 80
+   60    CONTINUE
+         J = JP1 - 1
+*
+   70    CONTINUE
+         M = L
+         IFLOW = 1
+         GO TO 160
+   80 CONTINUE
+      GO TO 100
+*
+*     Find column with one nonzero in rows K through N
+*
+   90 CONTINUE
+      K = K + 1
+*
+  100 CONTINUE
+      DO 150 J = K, L
+         DO 110 I = K, LM1
+            IP1 = I + 1
+            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
+     $         GO TO 120
+  110    CONTINUE
+         I = L
+         GO TO 140
+  120    CONTINUE
+         DO 130 I = IP1, L
+            IF( A( I, J ).NE.CZERO .OR. B( I, J ).NE.CZERO )
+     $         GO TO 150
+  130    CONTINUE
+         I = IP1 - 1
+  140    CONTINUE
+         M = K
+         IFLOW = 2
+         GO TO 160
+  150 CONTINUE
+      GO TO 190
+*
+*     Permute rows M and I
+*
+  160 CONTINUE
+      LSCALE( M ) = I
+      IF( I.EQ.M )
+     $   GO TO 170
+      CALL ZSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+      CALL ZSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
+*
+*     Permute columns M and J
+*
+  170 CONTINUE
+      RSCALE( M ) = J
+      IF( J.EQ.M )
+     $   GO TO 180
+      CALL ZSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+      CALL ZSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
+*
+  180 CONTINUE
+      GO TO ( 20, 90 )IFLOW
+*
+  190 CONTINUE
+      ILO = K
+      IHI = L
+*
+      IF( LSAME( JOB, 'P' ) ) THEN
+         DO 195 I = ILO, IHI
+            LSCALE( I ) = ONE
+            RSCALE( I ) = ONE
+  195    CONTINUE
+         RETURN
+      END IF
+*
+      IF( ILO.EQ.IHI )
+     $   RETURN
+*
+*     Balance the submatrix in rows ILO to IHI.
+*
+      NR = IHI - ILO + 1
+      DO 200 I = ILO, IHI
+         RSCALE( I ) = ZERO
+         LSCALE( I ) = ZERO
+*
+         WORK( I ) = ZERO
+         WORK( I+N ) = ZERO
+         WORK( I+2*N ) = ZERO
+         WORK( I+3*N ) = ZERO
+         WORK( I+4*N ) = ZERO
+         WORK( I+5*N ) = ZERO
+  200 CONTINUE
+*
+*     Compute right side vector in resulting linear equations
+*
+      BASL = LOG10( SCLFAC )
+      DO 240 I = ILO, IHI
+         DO 230 J = ILO, IHI
+            IF( A( I, J ).EQ.CZERO ) THEN
+               TA = ZERO
+               GO TO 210
+            END IF
+            TA = LOG10( CABS1( A( I, J ) ) ) / BASL
+*
+  210       CONTINUE
+            IF( B( I, J ).EQ.CZERO ) THEN
+               TB = ZERO
+               GO TO 220
+            END IF
+            TB = LOG10( CABS1( B( I, J ) ) ) / BASL
+*
+  220       CONTINUE
+            WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
+            WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
+  230    CONTINUE
+  240 CONTINUE
+*
+      COEF = ONE / DBLE( 2*NR )
+      COEF2 = COEF*COEF
+      COEF5 = HALF*COEF2
+      NRP2 = NR + 2
+      BETA = ZERO
+      IT = 1
+*
+*     Start generalized conjugate gradient iteration
+*
+  250 CONTINUE
+*
+      GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+     $        DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
+*
+      EW = ZERO
+      EWC = ZERO
+      DO 260 I = ILO, IHI
+         EW = EW + WORK( I+4*N )
+         EWC = EWC + WORK( I+5*N )
+  260 CONTINUE
+*
+      GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
+      IF( GAMMA.EQ.ZERO )
+     $   GO TO 350
+      IF( IT.NE.1 )
+     $   BETA = GAMMA / PGAMMA
+      T = COEF5*( EWC-THREE*EW )
+      TC = COEF5*( EW-THREE*EWC )
+*
+      CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
+      CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+      CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+      CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
+*
+      DO 270 I = ILO, IHI
+         WORK( I ) = WORK( I ) + TC
+         WORK( I+N ) = WORK( I+N ) + T
+  270 CONTINUE
+*
+*     Apply matrix to vector
+*
+      DO 300 I = ILO, IHI
+         KOUNT = 0
+         SUM = ZERO
+         DO 290 J = ILO, IHI
+            IF( A( I, J ).EQ.CZERO )
+     $         GO TO 280
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( J )
+  280       CONTINUE
+            IF( B( I, J ).EQ.CZERO )
+     $         GO TO 290
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( J )
+  290    CONTINUE
+         WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
+  300 CONTINUE
+*
+      DO 330 J = ILO, IHI
+         KOUNT = 0
+         SUM = ZERO
+         DO 320 I = ILO, IHI
+            IF( A( I, J ).EQ.CZERO )
+     $         GO TO 310
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( I+N )
+  310       CONTINUE
+            IF( B( I, J ).EQ.CZERO )
+     $         GO TO 320
+            KOUNT = KOUNT + 1
+            SUM = SUM + WORK( I+N )
+  320    CONTINUE
+         WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
+  330 CONTINUE
+*
+      SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+     $      DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
+      ALPHA = GAMMA / SUM
+*
+*     Determine correction to current iteration
+*
+      CMAX = ZERO
+      DO 340 I = ILO, IHI
+         COR = ALPHA*WORK( I+N )
+         IF( ABS( COR ).GT.CMAX )
+     $      CMAX = ABS( COR )
+         LSCALE( I ) = LSCALE( I ) + COR
+         COR = ALPHA*WORK( I )
+         IF( ABS( COR ).GT.CMAX )
+     $      CMAX = ABS( COR )
+         RSCALE( I ) = RSCALE( I ) + COR
+  340 CONTINUE
+      IF( CMAX.LT.HALF )
+     $   GO TO 350
+*
+      CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+      CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
+*
+      PGAMMA = GAMMA
+      IT = IT + 1
+      IF( IT.LE.NRP2 )
+     $   GO TO 250
+*
+*     End generalized conjugate gradient iteration
+*
+  350 CONTINUE
+      SFMIN = DLAMCH( 'S' )
+      SFMAX = ONE / SFMIN
+      LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+      LSFMAX = INT( LOG10( SFMAX ) / BASL )
+      DO 360 I = ILO, IHI
+         IRAB = IZAMAX( N-ILO+1, A( I, ILO ), LDA )
+         RAB = ABS( A( I, IRAB+ILO-1 ) )
+         IRAB = IZAMAX( N-ILO+1, B( I, ILO ), LDB )
+         RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
+         LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
+         IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
+         IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
+         LSCALE( I ) = SCLFAC**IR
+         ICAB = IZAMAX( IHI, A( 1, I ), 1 )
+         CAB = ABS( A( ICAB, I ) )
+         ICAB = IZAMAX( IHI, B( 1, I ), 1 )
+         CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
+         LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
+         JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
+         JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
+         RSCALE( I ) = SCLFAC**JC
+  360 CONTINUE
+*
+*     Row scaling of matrices A and B
+*
+      DO 370 I = ILO, IHI
+         CALL ZDSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+         CALL ZDSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+  370 CONTINUE
+*
+*     Column scaling of matrices A and B
+*
+      DO 380 J = ILO, IHI
+         CALL ZDSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+         CALL ZDSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+  380 CONTINUE
+*
+      RETURN
+*
+*     End of ZGGBAL
+*
+      END
diff --git a/src/lib/lapack/zgges.f b/src/lib/lapack/zgges.f
new file mode 100644
index 00000000..c1499003
--- /dev/null
+++ b/src/lib/lapack/zgges.f
@@ -0,0 +1,477 @@
+      SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
+     $                  SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
+     $                  LWORK, RWORK, BWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVSL, JOBVSR, SORT
+      INTEGER            INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            BWORK( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+     $                   WORK( * )
+*     ..
+*     .. Function Arguments ..
+      LOGICAL            SELCTG
+      EXTERNAL           SELCTG
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGES computes for a pair of N-by-N complex nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, the generalized complex Schur
+*  form (S, T), and optionally left and/or right Schur vectors (VSL
+*  and VSR). This gives the generalized Schur factorization
+*
+*          (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
+*
+*  where (VSR)**H is the conjugate-transpose of VSR.
+*
+*  Optionally, it also orders the eigenvalues so that a selected cluster
+*  of eigenvalues appears in the leading diagonal blocks of the upper
+*  triangular matrix S and the upper triangular matrix T. The leading
+*  columns of VSL and VSR then form an unitary basis for the
+*  corresponding left and right eigenspaces (deflating subspaces).
+*
+*  (If only the generalized eigenvalues are needed, use the driver
+*  ZGGEV instead, which is faster.)
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is
+*  usually represented as the pair (alpha,beta), as there is a
+*  reasonable interpretation for beta=0, and even for both being zero.
+*
+*  A pair of matrices (S,T) is in generalized complex Schur form if S
+*  and T are upper triangular and, in addition, the diagonal elements
+*  of T are non-negative real numbers.
+*
+*  Arguments
+*  =========
+*
+*  JOBVSL  (input) CHARACTER*1
+*          = 'N':  do not compute the left Schur vectors;
+*          = 'V':  compute the left Schur vectors.
+*
+*  JOBVSR  (input) CHARACTER*1
+*          = 'N':  do not compute the right Schur vectors;
+*          = 'V':  compute the right Schur vectors.
+*
+*  SORT    (input) CHARACTER*1
+*          Specifies whether or not to order the eigenvalues on the
+*          diagonal of the generalized Schur form.
+*          = 'N':  Eigenvalues are not ordered;
+*          = 'S':  Eigenvalues are ordered (see SELCTG).
+*
+*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments
+*          SELCTG must be declared EXTERNAL in the calling subroutine.
+*          If SORT = 'N', SELCTG is not referenced.
+*          If SORT = 'S', SELCTG is used to select eigenvalues to sort
+*          to the top left of the Schur form.
+*          An eigenvalue ALPHA(j)/BETA(j) is selected if
+*          SELCTG(ALPHA(j),BETA(j)) is true.
+*
+*          Note that a selected complex eigenvalue may no longer satisfy
+*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
+*          ordering may change the value of complex eigenvalues
+*          (especially if the eigenvalue is ill-conditioned), in this
+*          case INFO is set to N+2 (See INFO below).
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VSL, and VSR.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the first of the pair of matrices.
+*          On exit, A has been overwritten by its generalized Schur
+*          form S.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)
+*          On entry, the second of the pair of matrices.
+*          On exit, B has been overwritten by its generalized Schur
+*          form T.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  SDIM    (output) INTEGER
+*          If SORT = 'N', SDIM = 0.
+*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+*          for which SELCTG is true.
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the
+*          generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),
+*          j=1,...,N  are the diagonals of the complex Schur form (A,B)
+*          output by ZGGES. The  BETA(j) will be non-negative real.
+*
+*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
+*          underflow, and BETA(j) may even be zero.  Thus, the user
+*          should avoid naively computing the ratio alpha/beta.
+*          However, ALPHA will be always less than and usually
+*          comparable with norm(A) in magnitude, and BETA always less
+*          than and usually comparable with norm(B).
+*
+*  VSL     (output) COMPLEX*16 array, dimension (LDVSL,N)
+*          If JOBVSL = 'V', VSL will contain the left Schur vectors.
+*          Not referenced if JOBVSL = 'N'.
+*
+*  LDVSL   (input) INTEGER
+*          The leading dimension of the matrix VSL. LDVSL >= 1, and
+*          if JOBVSL = 'V', LDVSL >= N.
+*
+*  VSR     (output) COMPLEX*16 array, dimension (LDVSR,N)
+*          If JOBVSR = 'V', VSR will contain the right Schur vectors.
+*          Not referenced if JOBVSR = 'N'.
+*
+*  LDVSR   (input) INTEGER
+*          The leading dimension of the matrix VSR. LDVSR >= 1, and
+*          if JOBVSR = 'V', LDVSR >= N.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,2*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (8*N)
+*
+*  BWORK   (workspace) LOGICAL array, dimension (N)
+*          Not referenced if SORT = 'N'.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          =1,...,N:
+*                The QZ iteration failed.  (A,B) are not in Schur
+*                form, but ALPHA(j) and BETA(j) should be correct for
+*                j=INFO+1,...,N.
+*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ
+*                =N+2: after reordering, roundoff changed values of
+*                      some complex eigenvalues so that leading
+*                      eigenvalues in the Generalized Schur form no
+*                      longer satisfy SELCTG=.TRUE.  This could also
+*                      be caused due to scaling.
+*                =N+3: reordering falied in ZTGSEN.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+     $                   LQUERY, WANTST
+      INTEGER            I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
+     $                   ILO, IRIGHT, IROWS, IRWRK, ITAU, IWRK, LWKMIN,
+     $                   LWKOPT
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+     $                   PVSR, SMLNUM
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IDUM( 1 )
+      DOUBLE PRECISION   DIF( 2 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
+     $                   ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGSEN, ZUNGQR,
+     $                   ZUNMQR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVSL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVSL = .FALSE.
+      ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVSL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVSL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVSR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVSR = .FALSE.
+      ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVSR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVSR = .FALSE.
+      END IF
+*
+      WANTST = LSAME( SORT, 'S' )
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+         INFO = -16
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV.)
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 2*N )
+         LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
+         LWKOPT = MAX( LWKOPT, N +
+     $                 N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, -1 ) )
+         IF( ILVSL ) THEN
+            LWKOPT = MAX( LWKOPT, N +
+     $                    N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+     $      INFO = -18
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGES ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         SDIM = 0
+         RETURN
+      END IF
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+*
+      IF( ILASCL )
+     $   CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+*
+      IF( ILBSCL )
+     $   CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrix to make it more nearly triangular
+*     (Real Workspace: need 6*N)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWRK = IRIGHT + N
+      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      ICOLS = N + 1 - ILO
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VSL
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      IF( ILVSL ) THEN
+         CALL ZLASET( 'Full', N, N, CZERO, CONE, VSL, LDVSL )
+         IF( IROWS.GT.1 ) THEN
+            CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VSL( ILO+1, ILO ), LDVSL )
+         END IF
+         CALL ZUNGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VSR
+*
+      IF( ILVSR )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, VSR, LDVSR )
+*
+*     Reduce to generalized Hessenberg form
+*     (Workspace: none needed)
+*
+      CALL ZGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+     $             LDVSL, VSR, LDVSR, IERR )
+*
+      SDIM = 0
+*
+*     Perform QZ algorithm, computing Schur vectors if desired
+*     (Complex Workspace: need N)
+*     (Real Workspace: need N)
+*
+      IWRK = ITAU
+      CALL ZHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK( IWRK ),
+     $             LWORK+1-IWRK, RWORK( IRWRK ), IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 30
+      END IF
+*
+*     Sort eigenvalues ALPHA/BETA if desired
+*     (Workspace: none needed)
+*
+      IF( WANTST ) THEN
+*
+*        Undo scaling on eigenvalues before selecting
+*
+         IF( ILASCL )
+     $      CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, 1, ALPHA, N, IERR )
+         IF( ILBSCL )
+     $      CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, 1, BETA, N, IERR )
+*
+*        Select eigenvalues
+*
+         DO 10 I = 1, N
+            BWORK( I ) = SELCTG( ALPHA( I ), BETA( I ) )
+   10    CONTINUE
+*
+         CALL ZTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHA,
+     $                BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL, PVSR,
+     $                DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1, IERR )
+         IF( IERR.EQ.1 )
+     $      INFO = N + 3
+*
+      END IF
+*
+*     Apply back-permutation to VSL and VSR
+*     (Workspace: none needed)
+*
+      IF( ILVSL )
+     $   CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSL, LDVSL, IERR )
+      IF( ILVSR )
+     $   CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                RWORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+*     Undo scaling
+*
+      IF( ILASCL ) THEN
+         CALL ZLASCL( 'U', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+         CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+      END IF
+*
+      IF( ILBSCL ) THEN
+         CALL ZLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+         CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+      END IF
+*
+      IF( WANTST ) THEN
+*
+*        Check if reordering is correct
+*
+         LASTSL = .TRUE.
+         SDIM = 0
+         DO 20 I = 1, N
+            CURSL = SELCTG( ALPHA( I ), BETA( I ) )
+            IF( CURSL )
+     $         SDIM = SDIM + 1
+            IF( CURSL .AND. .NOT.LASTSL )
+     $         INFO = N + 2
+            LASTSL = CURSL
+   20    CONTINUE
+*
+      END IF
+*
+   30 CONTINUE
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZGGES
+*
+      END
diff --git a/src/lib/lapack/zggev.f b/src/lib/lapack/zggev.f
new file mode 100644
index 00000000..94fb3dc2
--- /dev/null
+++ b/src/lib/lapack/zggev.f
@@ -0,0 +1,454 @@
+      SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA,
+     $                  VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBVL, JOBVR
+      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
+*  (A,B), the generalized eigenvalues, and optionally, the left and/or
+*  right generalized eigenvectors.
+*
+*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+*  singular. It is usually represented as the pair (alpha,beta), as
+*  there is a reasonable interpretation for beta=0, and even for both
+*  being zero.
+*
+*  The right generalized eigenvector v(j) corresponding to the
+*  generalized eigenvalue lambda(j) of (A,B) satisfies
+*
+*               A * v(j) = lambda(j) * B * v(j).
+*
+*  The left generalized eigenvector u(j) corresponding to the
+*  generalized eigenvalues lambda(j) of (A,B) satisfies
+*
+*               u(j)**H * A = lambda(j) * u(j)**H * B
+*
+*  where u(j)**H is the conjugate-transpose of u(j).
+*
+*  Arguments
+*  =========
+*
+*  JOBVL   (input) CHARACTER*1
+*          = 'N':  do not compute the left generalized eigenvectors;
+*          = 'V':  compute the left generalized eigenvectors.
+*
+*  JOBVR   (input) CHARACTER*1
+*          = 'N':  do not compute the right generalized eigenvectors;
+*          = 'V':  compute the right generalized eigenvectors.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A, B, VL, and VR.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the matrix A in the pair (A,B).
+*          On exit, A has been overwritten.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)
+*          On entry, the matrix B in the pair (A,B).
+*          On exit, B has been overwritten.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of B.  LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
+*          generalized eigenvalues.
+*
+*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or
+*          underflow, and BETA(j) may even be zero.  Thus, the user
+*          should avoid naively computing the ratio alpha/beta.
+*          However, ALPHA will be always less than and usually
+*          comparable with norm(A) in magnitude, and BETA always less
+*          than and usually comparable with norm(B).
+*
+*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)
+*          If JOBVL = 'V', the left generalized eigenvectors u(j) are
+*          stored one after another in the columns of VL, in the same
+*          order as their eigenvalues.
+*          Each eigenvector is scaled so the largest component has
+*          abs(real part) + abs(imag. part) = 1.
+*          Not referenced if JOBVL = 'N'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the matrix VL. LDVL >= 1, and
+*          if JOBVL = 'V', LDVL >= N.
+*
+*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)
+*          If JOBVR = 'V', the right generalized eigenvectors v(j) are
+*          stored one after another in the columns of VR, in the same
+*          order as their eigenvalues.
+*          Each eigenvector is scaled so the largest component has
+*          abs(real part) + abs(imag. part) = 1.
+*          Not referenced if JOBVR = 'N'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the matrix VR. LDVR >= 1, and
+*          if JOBVR = 'V', LDVR >= N.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,2*N).
+*          For good performance, LWORK must generally be larger.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (8*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*          =1,...,N:
+*                The QZ iteration failed.  No eigenvectors have been
+*                calculated, but ALPHA(j) and BETA(j) should be
+*                correct for j=INFO+1,...,N.
+*          > N:  =N+1: other then QZ iteration failed in DHGEQZ,
+*                =N+2: error return from DTGEVC.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
+      CHARACTER          CHTEMP
+      INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
+     $                   IN, IRIGHT, IROWS, IRWRK, ITAU, IWRK, JC, JR,
+     $                   LWKMIN, LWKOPT
+      DOUBLE PRECISION   ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+     $                   SMLNUM, TEMP
+      COMPLEX*16         X
+*     ..
+*     .. Local Arrays ..
+      LOGICAL            LDUMMA( 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZGEQRF, ZGGBAK, ZGGBAL, ZGGHRD,
+     $                   ZHGEQZ, ZLACPY, ZLASCL, ZLASET, ZTGEVC, ZUNGQR,
+     $                   ZUNMQR
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANGE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG, MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode the input arguments
+*
+      IF( LSAME( JOBVL, 'N' ) ) THEN
+         IJOBVL = 1
+         ILVL = .FALSE.
+      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+         IJOBVL = 2
+         ILVL = .TRUE.
+      ELSE
+         IJOBVL = -1
+         ILVL = .FALSE.
+      END IF
+*
+      IF( LSAME( JOBVR, 'N' ) ) THEN
+         IJOBVR = 1
+         ILVR = .FALSE.
+      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+         IJOBVR = 2
+         ILVR = .TRUE.
+      ELSE
+         IJOBVR = -1
+         ILVR = .FALSE.
+      END IF
+      ILV = ILVL .OR. ILVR
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( IJOBVL.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( IJOBVR.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+         INFO = -11
+      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+         INFO = -13
+      END IF
+*
+*     Compute workspace
+*      (Note: Comments in the code beginning "Workspace:" describe the
+*       minimal amount of workspace needed at that point in the code,
+*       as well as the preferred amount for good performance.
+*       NB refers to the optimal block size for the immediately
+*       following subroutine, as returned by ILAENV. The workspace is
+*       computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+      IF( INFO.EQ.0 ) THEN
+         LWKMIN = MAX( 1, 2*N )
+         LWKOPT = MAX( 1, N + N*ILAENV( 1, 'ZGEQRF', ' ', N, 1, N, 0 ) )
+         LWKOPT = MAX( LWKOPT, N +
+     $                 N*ILAENV( 1, 'ZUNMQR', ' ', N, 1, N, 0 ) )
+         IF( ILVL ) THEN
+            LWKOPT = MAX( LWKOPT, N +
+     $                    N*ILAENV( 1, 'ZUNGQR', ' ', N, 1, N, -1 ) )
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+     $      INFO = -15
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Get machine constants
+*
+      EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SQRT( SMLNUM ) / EPS
+      BIGNUM = ONE / SMLNUM
+*
+*     Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+      ANRM = ZLANGE( 'M', N, N, A, LDA, RWORK )
+      ILASCL = .FALSE.
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+         ANRMTO = SMLNUM
+         ILASCL = .TRUE.
+      ELSE IF( ANRM.GT.BIGNUM ) THEN
+         ANRMTO = BIGNUM
+         ILASCL = .TRUE.
+      END IF
+      IF( ILASCL )
+     $   CALL ZLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+*     Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+      BNRM = ZLANGE( 'M', N, N, B, LDB, RWORK )
+      ILBSCL = .FALSE.
+      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+         BNRMTO = SMLNUM
+         ILBSCL = .TRUE.
+      ELSE IF( BNRM.GT.BIGNUM ) THEN
+         BNRMTO = BIGNUM
+         ILBSCL = .TRUE.
+      END IF
+      IF( ILBSCL )
+     $   CALL ZLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+*     Permute the matrices A, B to isolate eigenvalues if possible
+*     (Real Workspace: need 6*N)
+*
+      ILEFT = 1
+      IRIGHT = N + 1
+      IRWRK = IRIGHT + N
+      CALL ZGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, RWORK( ILEFT ),
+     $             RWORK( IRIGHT ), RWORK( IRWRK ), IERR )
+*
+*     Reduce B to triangular form (QR decomposition of B)
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      IROWS = IHI + 1 - ILO
+      IF( ILV ) THEN
+         ICOLS = N + 1 - ILO
+      ELSE
+         ICOLS = IROWS
+      END IF
+      ITAU = 1
+      IWRK = ITAU + IROWS
+      CALL ZGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+*     Apply the orthogonal transformation to matrix A
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      CALL ZUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+     $             LWORK+1-IWRK, IERR )
+*
+*     Initialize VL
+*     (Complex Workspace: need N, prefer N*NB)
+*
+      IF( ILVL ) THEN
+         CALL ZLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
+         IF( IROWS.GT.1 ) THEN
+            CALL ZLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+     $                   VL( ILO+1, ILO ), LDVL )
+         END IF
+         CALL ZUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+      END IF
+*
+*     Initialize VR
+*
+      IF( ILVR )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
+*
+*     Reduce to generalized Hessenberg form
+*
+      IF( ILV ) THEN
+*
+*        Eigenvectors requested -- work on whole matrix.
+*
+         CALL ZGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+     $                LDVL, VR, LDVR, IERR )
+      ELSE
+         CALL ZGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+      END IF
+*
+*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
+*     Schur form and Schur vectors)
+*     (Complex Workspace: need N)
+*     (Real Workspace: need N)
+*
+      IWRK = ITAU
+      IF( ILV ) THEN
+         CHTEMP = 'S'
+      ELSE
+         CHTEMP = 'E'
+      END IF
+      CALL ZHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+     $             ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
+     $             LWORK+1-IWRK, RWORK( IRWRK ), IERR )
+      IF( IERR.NE.0 ) THEN
+         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+            INFO = IERR
+         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+            INFO = IERR - N
+         ELSE
+            INFO = N + 1
+         END IF
+         GO TO 70
+      END IF
+*
+*     Compute Eigenvectors
+*     (Real Workspace: need 2*N)
+*     (Complex Workspace: need 2*N)
+*
+      IF( ILV ) THEN
+         IF( ILVL ) THEN
+            IF( ILVR ) THEN
+               CHTEMP = 'B'
+            ELSE
+               CHTEMP = 'L'
+            END IF
+         ELSE
+            CHTEMP = 'R'
+         END IF
+*
+         CALL ZTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+     $                VR, LDVR, N, IN, WORK( IWRK ), RWORK( IRWRK ),
+     $                IERR )
+         IF( IERR.NE.0 ) THEN
+            INFO = N + 2
+            GO TO 70
+         END IF
+*
+*        Undo balancing on VL and VR and normalization
+*        (Workspace: none needed)
+*
+         IF( ILVL ) THEN
+            CALL ZGGBAK( 'P', 'L', N, ILO, IHI, RWORK( ILEFT ),
+     $                   RWORK( IRIGHT ), N, VL, LDVL, IERR )
+            DO 30 JC = 1, N
+               TEMP = ZERO
+               DO 10 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
+   10          CONTINUE
+               IF( TEMP.LT.SMLNUM )
+     $            GO TO 30
+               TEMP = ONE / TEMP
+               DO 20 JR = 1, N
+                  VL( JR, JC ) = VL( JR, JC )*TEMP
+   20          CONTINUE
+   30       CONTINUE
+         END IF
+         IF( ILVR ) THEN
+            CALL ZGGBAK( 'P', 'R', N, ILO, IHI, RWORK( ILEFT ),
+     $                   RWORK( IRIGHT ), N, VR, LDVR, IERR )
+            DO 60 JC = 1, N
+               TEMP = ZERO
+               DO 40 JR = 1, N
+                  TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
+   40          CONTINUE
+               IF( TEMP.LT.SMLNUM )
+     $            GO TO 60
+               TEMP = ONE / TEMP
+               DO 50 JR = 1, N
+                  VR( JR, JC ) = VR( JR, JC )*TEMP
+   50          CONTINUE
+   60       CONTINUE
+         END IF
+      END IF
+*
+*     Undo scaling if necessary
+*
+      IF( ILASCL )
+     $   CALL ZLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
+*
+      IF( ILBSCL )
+     $   CALL ZLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+   70 CONTINUE
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZGGEV
+*
+      END
diff --git a/src/lib/lapack/zgghrd.f b/src/lib/lapack/zgghrd.f
new file mode 100644
index 00000000..652c09d7
--- /dev/null
+++ b/src/lib/lapack/zgghrd.f
@@ -0,0 +1,264 @@
+      SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
+     $                   LDQ, Z, LDZ, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, COMPZ
+      INTEGER            IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
+*  Hessenberg form using unitary transformations, where A is a
+*  general matrix and B is upper triangular.  The form of the
+*  generalized eigenvalue problem is
+*     A*x = lambda*B*x,
+*  and B is typically made upper triangular by computing its QR
+*  factorization and moving the unitary matrix Q to the left side
+*  of the equation.
+*
+*  This subroutine simultaneously reduces A to a Hessenberg matrix H:
+*     Q**H*A*Z = H
+*  and transforms B to another upper triangular matrix T:
+*     Q**H*B*Z = T
+*  in order to reduce the problem to its standard form
+*     H*y = lambda*T*y
+*  where y = Z**H*x.
+*
+*  The unitary matrices Q and Z are determined as products of Givens
+*  rotations.  They may either be formed explicitly, or they may be
+*  postmultiplied into input matrices Q1 and Z1, so that
+*       Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
+*       Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
+*  If Q1 is the unitary matrix from the QR factorization of B in the
+*  original equation A*x = lambda*B*x, then ZGGHRD reduces the original
+*  problem to generalized Hessenberg form.
+*
+*  Arguments
+*  =========
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'N': do not compute Q;
+*          = 'I': Q is initialized to the unit matrix, and the
+*                 unitary matrix Q is returned;
+*          = 'V': Q must contain a unitary matrix Q1 on entry,
+*                 and the product Q1*Q is returned.
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N': do not compute Q;
+*          = 'I': Q is initialized to the unit matrix, and the
+*                 unitary matrix Q is returned;
+*          = 'V': Q must contain a unitary matrix Q1 on entry,
+*                 and the product Q1*Q is returned.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI mark the rows and columns of A which are to be
+*          reduced.  It is assumed that A is already upper triangular
+*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are
+*          normally set by a previous call to ZGGBAL; otherwise they
+*          should be set to 1 and N respectively.
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the N-by-N general matrix to be reduced.
+*          On exit, the upper triangle and the first subdiagonal of A
+*          are overwritten with the upper Hessenberg matrix H, and the
+*          rest is set to zero.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)
+*          On entry, the N-by-N upper triangular matrix B.
+*          On exit, the upper triangular matrix T = Q**H B Z.  The
+*          elements below the diagonal are set to zero.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,N).
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
+*          On entry, if COMPQ = 'V', the unitary matrix Q1, typically
+*          from the QR factorization of B.
+*          On exit, if COMPQ='I', the unitary matrix Q, and if
+*          COMPQ = 'V', the product Q1*Q.
+*          Not referenced if COMPQ='N'.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the unitary matrix Z1.
+*          On exit, if COMPZ='I', the unitary matrix Z, and if
+*          COMPZ = 'V', the product Z1*Z.
+*          Not referenced if COMPZ='N'.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.
+*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  This routine reduces A to Hessenberg and B to triangular form by
+*  an unblocked reduction, as described in _Matrix_Computations_,
+*  by Golub and van Loan (Johns Hopkins Press).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CONE, CZERO
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ),
+     $                   CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILQ, ILZ
+      INTEGER            ICOMPQ, ICOMPZ, JCOL, JROW
+      DOUBLE PRECISION   C
+      COMPLEX*16         CTEMP, S
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARTG, ZLASET, ZROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode COMPQ
+*
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ILQ = .FALSE.
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 2
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 3
+      ELSE
+         ICOMPQ = 0
+      END IF
+*
+*     Decode COMPZ
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ILZ = .FALSE.
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 2
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 3
+      ELSE
+         ICOMPZ = 0
+      END IF
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF( ICOMPQ.LE.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPZ.LE.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -4
+      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
+         INFO = -11
+      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZGGHRD', -INFO )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z if desired.
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+*     Zero out lower triangle of B
+*
+      DO 20 JCOL = 1, N - 1
+         DO 10 JROW = JCOL + 1, N
+            B( JROW, JCOL ) = CZERO
+   10    CONTINUE
+   20 CONTINUE
+*
+*     Reduce A and B
+*
+      DO 40 JCOL = ILO, IHI - 2
+*
+         DO 30 JROW = IHI, JCOL + 2, -1
+*
+*           Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
+*
+            CTEMP = A( JROW-1, JCOL )
+            CALL ZLARTG( CTEMP, A( JROW, JCOL ), C, S,
+     $                   A( JROW-1, JCOL ) )
+            A( JROW, JCOL ) = CZERO
+            CALL ZROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+     $                 A( JROW, JCOL+1 ), LDA, C, S )
+            CALL ZROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+     $                 B( JROW, JROW-1 ), LDB, C, S )
+            IF( ILQ )
+     $         CALL ZROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C,
+     $                    DCONJG( S ) )
+*
+*           Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
+*
+            CTEMP = B( JROW, JROW )
+            CALL ZLARTG( CTEMP, B( JROW, JROW-1 ), C, S,
+     $                   B( JROW, JROW ) )
+            B( JROW, JROW-1 ) = CZERO
+            CALL ZROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+            CALL ZROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+     $                 S )
+            IF( ILZ )
+     $         CALL ZROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+   30    CONTINUE
+   40 CONTINUE
+*
+      RETURN
+*
+*     End of ZGGHRD
+*
+      END
diff --git a/src/lib/lapack/zheev.f b/src/lib/lapack/zheev.f
new file mode 100644
index 00000000..324d1612
--- /dev/null
+++ b/src/lib/lapack/zheev.f
@@ -0,0 +1,218 @@
+      SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
+     $                  INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          JOBZ, UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * ), W( * )
+      COMPLEX*16         A( LDA, * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
+*  complex Hermitian matrix A.
+*
+*  Arguments
+*  =========
+*
+*  JOBZ    (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only;
+*          = 'V':  Compute eigenvalues and eigenvectors.
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of A contains the
+*          upper triangular part of the matrix A.  If UPLO = 'L',
+*          the leading N-by-N lower triangular part of A contains
+*          the lower triangular part of the matrix A.
+*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+*          orthonormal eigenvectors of the matrix A.
+*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+*          or the upper triangle (if UPLO='U') of A, including the
+*          diagonal, is destroyed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  W       (output) DOUBLE PRECISION array, dimension (N)
+*          If INFO = 0, the eigenvalues in ascending order.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The length of the array WORK.  LWORK >= max(1,2*N-1).
+*          For optimal efficiency, LWORK >= (NB+1)*N,
+*          where NB is the blocksize for ZHETRD returned by ILAENV.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the algorithm failed to converge; i
+*                off-diagonal elements of an intermediate tridiagonal
+*                form did not converge to zero.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LOWER, LQUERY, WANTZ
+      INTEGER            IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+     $                   LLWORK, LWKOPT, NB
+      DOUBLE PRECISION   ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+     $                   SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      DOUBLE PRECISION   DLAMCH, ZLANHE
+      EXTERNAL           LSAME, ILAENV, DLAMCH, ZLANHE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, DSTERF, XERBLA, ZHETRD, ZLASCL, ZSTEQR,
+     $                   ZUNGTR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      WANTZ = LSAME( JOBZ, 'V' )
+      LOWER = LSAME( UPLO, 'L' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      INFO = 0
+      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = MAX( 1, ( NB+1 )*N )
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, 2*N-1 ) .AND. .NOT.LQUERY )
+     $      INFO = -8
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHEEV ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+      IF( N.EQ.1 ) THEN
+         W( 1 ) = A( 1, 1 )
+         WORK( 1 ) = 1
+         IF( WANTZ )
+     $      A( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Get machine constants.
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      EPS = DLAMCH( 'Precision' )
+      SMLNUM = SAFMIN / EPS
+      BIGNUM = ONE / SMLNUM
+      RMIN = SQRT( SMLNUM )
+      RMAX = SQRT( BIGNUM )
+*
+*     Scale matrix to allowable range, if necessary.
+*
+      ANRM = ZLANHE( 'M', UPLO, N, A, LDA, RWORK )
+      ISCALE = 0
+      IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+         ISCALE = 1
+         SIGMA = RMIN / ANRM
+      ELSE IF( ANRM.GT.RMAX ) THEN
+         ISCALE = 1
+         SIGMA = RMAX / ANRM
+      END IF
+      IF( ISCALE.EQ.1 )
+     $   CALL ZLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+*     Call ZHETRD to reduce Hermitian matrix to tridiagonal form.
+*
+      INDE = 1
+      INDTAU = 1
+      INDWRK = INDTAU + N
+      LLWORK = LWORK - INDWRK + 1
+      CALL ZHETRD( UPLO, N, A, LDA, W, RWORK( INDE ), WORK( INDTAU ),
+     $             WORK( INDWRK ), LLWORK, IINFO )
+*
+*     For eigenvalues only, call DSTERF.  For eigenvectors, first call
+*     ZUNGTR to generate the unitary matrix, then call ZSTEQR.
+*
+      IF( .NOT.WANTZ ) THEN
+         CALL DSTERF( N, W, RWORK( INDE ), INFO )
+      ELSE
+         CALL ZUNGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+     $                LLWORK, IINFO )
+         INDWRK = INDE + N
+         CALL ZSTEQR( JOBZ, N, W, RWORK( INDE ), A, LDA,
+     $                RWORK( INDWRK ), INFO )
+      END IF
+*
+*     If matrix was scaled, then rescale eigenvalues appropriately.
+*
+      IF( ISCALE.EQ.1 ) THEN
+         IF( INFO.EQ.0 ) THEN
+            IMAX = N
+         ELSE
+            IMAX = INFO - 1
+         END IF
+         CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+      END IF
+*
+*     Set WORK(1) to optimal complex workspace size.
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZHEEV
+*
+      END
diff --git a/src/lib/lapack/zhetd2.f b/src/lib/lapack/zhetd2.f
new file mode 100644
index 00000000..24b0a1df
--- /dev/null
+++ b/src/lib/lapack/zhetd2.f
@@ -0,0 +1,258 @@
+      SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETD2 reduces a complex Hermitian matrix A to real symmetric
+*  tridiagonal form T by a unitary similarity transformation:
+*  Q' * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          Hermitian matrix A is stored:
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
+*          of A are overwritten by the corresponding elements of the
+*          tridiagonal matrix T, and the elements above the first
+*          superdiagonal, with the array TAU, represent the unitary
+*          matrix Q as a product of elementary reflectors; if UPLO
+*          = 'L', the diagonal and first subdiagonal of A are over-
+*          written by the corresponding elements of the tridiagonal
+*          matrix T, and the elements below the first subdiagonal, with
+*          the array TAU, represent the unitary matrix Q as a product
+*          of elementary reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n-1) . . . H(2) H(1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+*  A(1:i-1,i+1), and tau in TAU(i).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(n-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+*  and tau in TAU(i).
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  d   e   v2  v3  v4 )              (  d                  )
+*    (      d   e   v3  v4 )              (  e   d              )
+*    (          d   e   v4 )              (  v1  e   d          )
+*    (              d   e  )              (  v1  v2  e   d      )
+*    (                  d  )              (  v1  v2  v3  e   d  )
+*
+*  where d and e denote diagonal and off-diagonal elements of T, and vi
+*  denotes an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO, HALF
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            I
+      COMPLEX*16         ALPHA, TAUI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZHEMV, ZHER2, ZLARFG
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHETD2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Reduce the upper triangle of A
+*
+         A( N, N ) = DBLE( A( N, N ) )
+         DO 10 I = N - 1, 1, -1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(1:i-1,i+1)
+*
+            ALPHA = A( I, I+1 )
+            CALL ZLARFG( I, ALPHA, A( 1, I+1 ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(1:i,1:i)
+*
+               A( I, I+1 ) = ONE
+*
+*              Compute  x := tau * A * v  storing x in TAU(1:i)
+*
+               CALL ZHEMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
+     $                     TAU, 1 )
+*
+*              Compute  w := x - 1/2 * tau * (x'*v) * v
+*
+               ALPHA = -HALF*TAUI*ZDOTC( I, TAU, 1, A( 1, I+1 ), 1 )
+               CALL ZAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL ZHER2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
+     $                     LDA )
+*
+            ELSE
+               A( I, I ) = DBLE( A( I, I ) )
+            END IF
+            A( I, I+1 ) = E( I )
+            D( I+1 ) = A( I+1, I+1 )
+            TAU( I ) = TAUI
+   10    CONTINUE
+         D( 1 ) = A( 1, 1 )
+      ELSE
+*
+*        Reduce the lower triangle of A
+*
+         A( 1, 1 ) = DBLE( A( 1, 1 ) )
+         DO 20 I = 1, N - 1
+*
+*           Generate elementary reflector H(i) = I - tau * v * v'
+*           to annihilate A(i+2:n,i)
+*
+            ALPHA = A( I+1, I )
+            CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAUI )
+            E( I ) = ALPHA
+*
+            IF( TAUI.NE.ZERO ) THEN
+*
+*              Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+               A( I+1, I ) = ONE
+*
+*              Compute  x := tau * A * v  storing y in TAU(i:n-1)
+*
+               CALL ZHEMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, TAU( I ), 1 )
+*
+*              Compute  w := x - 1/2 * tau * (x'*v) * v
+*
+               ALPHA = -HALF*TAUI*ZDOTC( N-I, TAU( I ), 1, A( I+1, I ),
+     $                 1 )
+               CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
+*
+*              Apply the transformation as a rank-2 update:
+*                 A := A - v * w' - w * v'
+*
+               CALL ZHER2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
+     $                     A( I+1, I+1 ), LDA )
+*
+            ELSE
+               A( I+1, I+1 ) = DBLE( A( I+1, I+1 ) )
+            END IF
+            A( I+1, I ) = E( I )
+            D( I ) = A( I, I )
+            TAU( I ) = TAUI
+   20    CONTINUE
+         D( N ) = A( N, N )
+      END IF
+*
+      RETURN
+*
+*     End of ZHETD2
+*
+      END
diff --git a/src/lib/lapack/zhetrd.f b/src/lib/lapack/zhetrd.f
new file mode 100644
index 00000000..fb0cd0b2
--- /dev/null
+++ b/src/lib/lapack/zhetrd.f
@@ -0,0 +1,296 @@
+      SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHETRD reduces a complex Hermitian matrix A to real symmetric
+*  tridiagonal form T by a unitary similarity transformation:
+*  Q**H * A * Q = T.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit, if UPLO = 'U', the diagonal and first superdiagonal
+*          of A are overwritten by the corresponding elements of the
+*          tridiagonal matrix T, and the elements above the first
+*          superdiagonal, with the array TAU, represent the unitary
+*          matrix Q as a product of elementary reflectors; if UPLO
+*          = 'L', the diagonal and first subdiagonal of A are over-
+*          written by the corresponding elements of the tridiagonal
+*          matrix T, and the elements below the first subdiagonal, with
+*          the array TAU, represent the unitary matrix Q as a product
+*          of elementary reflectors. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (N)
+*          The diagonal elements of the tridiagonal matrix T:
+*          D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          The off-diagonal elements of the tridiagonal matrix T:
+*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors (see Further
+*          Details).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= 1.
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n-1) . . . H(2) H(1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+*  A(1:i-1,i+1), and tau in TAU(i).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(n-1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+*  and tau in TAU(i).
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  d   e   v2  v3  v4 )              (  d                  )
+*    (      d   e   v3  v4 )              (  e   d              )
+*    (          d   e   v4 )              (  v1  e   d          )
+*    (              d   e  )              (  v1  v2  e   d      )
+*    (                  d  )              (  v1  v2  v3  e   d  )
+*
+*  where d and e denote diagonal and off-diagonal elements of T, and vi
+*  denotes an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZHER2K, ZHETD2, ZLATRD
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.
+*
+         NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 )
+         LWKOPT = N*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHETRD', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NX = N
+      IWS = 1
+      IF( NB.GT.1 .AND. NB.LT.N ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code
+*        (last block is always handled by unblocked code).
+*
+         NX = MAX( NB, ILAENV( 3, 'ZHETRD', UPLO, N, -1, -1, -1 ) )
+         IF( NX.LT.N ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  determine the
+*              minimum value of NB, and reduce NB or force use of
+*              unblocked code by setting NX = N.
+*
+               NB = MAX( LWORK / LDWORK, 1 )
+               NBMIN = ILAENV( 2, 'ZHETRD', UPLO, N, -1, -1, -1 )
+               IF( NB.LT.NBMIN )
+     $            NX = N
+            END IF
+         ELSE
+            NX = N
+         END IF
+      ELSE
+         NB = 1
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Reduce the upper triangle of A.
+*        Columns 1:kk are handled by the unblocked method.
+*
+         KK = N - ( ( N-NX+NB-1 ) / NB )*NB
+         DO 20 I = N - NB + 1, KK + 1, -NB
+*
+*           Reduce columns i:i+nb-1 to tridiagonal form and form the
+*           matrix W which is needed to update the unreduced part of
+*           the matrix
+*
+            CALL ZLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
+     $                   LDWORK )
+*
+*           Update the unreduced submatrix A(1:i-1,1:i-1), using an
+*           update of the form:  A := A - V*W' - W*V'
+*
+            CALL ZHER2K( UPLO, 'No transpose', I-1, NB, -CONE,
+     $                   A( 1, I ), LDA, WORK, LDWORK, ONE, A, LDA )
+*
+*           Copy superdiagonal elements back into A, and diagonal
+*           elements into D
+*
+            DO 10 J = I, I + NB - 1
+               A( J-1, J ) = E( J-1 )
+               D( J ) = A( J, J )
+   10       CONTINUE
+   20    CONTINUE
+*
+*        Use unblocked code to reduce the last or only block
+*
+         CALL ZHETD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
+      ELSE
+*
+*        Reduce the lower triangle of A
+*
+         DO 40 I = 1, N - NX, NB
+*
+*           Reduce columns i:i+nb-1 to tridiagonal form and form the
+*           matrix W which is needed to update the unreduced part of
+*           the matrix
+*
+            CALL ZLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
+     $                   TAU( I ), WORK, LDWORK )
+*
+*           Update the unreduced submatrix A(i+nb:n,i+nb:n), using
+*           an update of the form:  A := A - V*W' - W*V'
+*
+            CALL ZHER2K( UPLO, 'No transpose', N-I-NB+1, NB, -CONE,
+     $                   A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
+     $                   A( I+NB, I+NB ), LDA )
+*
+*           Copy subdiagonal elements back into A, and diagonal
+*           elements into D
+*
+            DO 30 J = I, I + NB - 1
+               A( J+1, J ) = E( J )
+               D( J ) = A( J, J )
+   30       CONTINUE
+   40    CONTINUE
+*
+*        Use unblocked code to reduce the last or only block
+*
+         CALL ZHETD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+     $                TAU( I ), IINFO )
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZHETRD
+*
+      END
diff --git a/src/lib/lapack/zhgeqz.f b/src/lib/lapack/zhgeqz.f
new file mode 100644
index 00000000..6a9403bd
--- /dev/null
+++ b/src/lib/lapack/zhgeqz.f
@@ -0,0 +1,759 @@
+      SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
+     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK,
+     $                   RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, COMPZ, JOB
+      INTEGER            IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         ALPHA( * ), BETA( * ), H( LDH, * ),
+     $                   Q( LDQ, * ), T( LDT, * ), WORK( * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
+*  where H is an upper Hessenberg matrix and T is upper triangular,
+*  using the single-shift QZ method.
+*  Matrix pairs of this type are produced by the reduction to
+*  generalized upper Hessenberg form of a complex matrix pair (A,B):
+*  
+*     A = Q1*H*Z1**H,  B = Q1*T*Z1**H,
+*  
+*  as computed by ZGGHRD.
+*  
+*  If JOB='S', then the Hessenberg-triangular pair (H,T) is
+*  also reduced to generalized Schur form,
+*  
+*     H = Q*S*Z**H,  T = Q*P*Z**H,
+*  
+*  where Q and Z are unitary matrices and S and P are upper triangular.
+*  
+*  Optionally, the unitary matrix Q from the generalized Schur
+*  factorization may be postmultiplied into an input matrix Q1, and the
+*  unitary matrix Z may be postmultiplied into an input matrix Z1.
+*  If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced
+*  the matrix pair (A,B) to generalized Hessenberg form, then the output
+*  matrices Q1*Q and Z1*Z are the unitary factors from the generalized
+*  Schur factorization of (A,B):
+*  
+*     A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.
+*  
+*  To avoid overflow, eigenvalues of the matrix pair (H,T)
+*  (equivalently, of (A,B)) are computed as a pair of complex values
+*  (alpha,beta).  If beta is nonzero, lambda = alpha / beta is an
+*  eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)
+*     A*x = lambda*B*x
+*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
+*  alternate form of the GNEP
+*     mu*A*y = B*y.
+*  The values of alpha and beta for the i-th eigenvalue can be read
+*  directly from the generalized Schur form:  alpha = S(i,i),
+*  beta = P(i,i).
+*
+*  Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
+*       Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
+*       pp. 241--256.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          = 'E': Compute eigenvalues only;
+*          = 'S': Computer eigenvalues and the Schur form.
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'N': Left Schur vectors (Q) are not computed;
+*          = 'I': Q is initialized to the unit matrix and the matrix Q
+*                 of left Schur vectors of (H,T) is returned;
+*          = 'V': Q must contain a unitary matrix Q1 on entry and
+*                 the product Q1*Q is returned.
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N': Right Schur vectors (Z) are not computed;
+*          = 'I': Q is initialized to the unit matrix and the matrix Z
+*                 of right Schur vectors of (H,T) is returned;
+*          = 'V': Z must contain a unitary matrix Z1 on entry and
+*                 the product Z1*Z is returned.
+*
+*  N       (input) INTEGER
+*          The order of the matrices H, T, Q, and Z.  N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI mark the rows and columns of H which are in
+*          Hessenberg form.  It is assumed that A is already upper
+*          triangular in rows and columns 1:ILO-1 and IHI+1:N.
+*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
+*
+*  H       (input/output) COMPLEX*16 array, dimension (LDH, N)
+*          On entry, the N-by-N upper Hessenberg matrix H.
+*          On exit, if JOB = 'S', H contains the upper triangular
+*          matrix S from the generalized Schur factorization.
+*          If JOB = 'E', the diagonal of H matches that of S, but
+*          the rest of H is unspecified.
+*
+*  LDH     (input) INTEGER
+*          The leading dimension of the array H.  LDH >= max( 1, N ).
+*
+*  T       (input/output) COMPLEX*16 array, dimension (LDT, N)
+*          On entry, the N-by-N upper triangular matrix T.
+*          On exit, if JOB = 'S', T contains the upper triangular
+*          matrix P from the generalized Schur factorization.
+*          If JOB = 'E', the diagonal of T matches that of P, but
+*          the rest of T is unspecified.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= max( 1, N ).
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*          The complex scalars alpha that define the eigenvalues of
+*          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur
+*          factorization.
+*
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          The real non-negative scalars beta that define the
+*          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized
+*          Schur factorization.
+*
+*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
+*          represent the j-th eigenvalue of the matrix pair (A,B), in
+*          one of the forms lambda = alpha/beta or mu = beta/alpha.
+*          Since either lambda or mu may overflow, they should not,
+*          in general, be computed.
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)
+*          On entry, if COMPZ = 'V', the unitary matrix Q1 used in the
+*          reduction of (A,B) to generalized Hessenberg form.
+*          On exit, if COMPZ = 'I', the unitary matrix of left Schur
+*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
+*          left Schur vectors of (A,B).
+*          Not referenced if COMPZ = 'N'.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= 1.
+*          If COMPQ='V' or 'I', then LDQ >= N.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
+*          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
+*          reduction of (A,B) to generalized Hessenberg form.
+*          On exit, if COMPZ = 'I', the unitary matrix of right Schur
+*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
+*          right Schur vectors of (A,B).
+*          Not referenced if COMPZ = 'N'.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1.
+*          If COMPZ='V' or 'I', then LDZ >= N.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,N).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not
+*                     in Schur form, but ALPHA(i) and BETA(i),
+*                     i=INFO+1,...,N should be correct.
+*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not
+*                     in Schur form, but ALPHA(i) and BETA(i),
+*                     i=INFO-N+1,...,N should be correct.
+*
+*  Further Details
+*  ===============
+*
+*  We assume that complex ABS works as long as its value is less than
+*  overflow.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      DOUBLE PRECISION   HALF
+      PARAMETER          ( HALF = 0.5D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ILAZR2, ILAZRO, ILQ, ILSCHR, ILZ, LQUERY
+      INTEGER            ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
+     $                   ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
+     $                   JR, MAXIT
+      DOUBLE PRECISION   ABSB, ANORM, ASCALE, ATOL, BNORM, BSCALE, BTOL,
+     $                   C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
+      COMPLEX*16         ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
+     $                   CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1,
+     $                   U12, X
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANHS
+      EXTERNAL           LSAME, DLAMCH, ZLANHS
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode JOB, COMPQ, COMPZ
+*
+      IF( LSAME( JOB, 'E' ) ) THEN
+         ILSCHR = .FALSE.
+         ISCHUR = 1
+      ELSE IF( LSAME( JOB, 'S' ) ) THEN
+         ILSCHR = .TRUE.
+         ISCHUR = 2
+      ELSE
+         ISCHUR = 0
+      END IF
+*
+      IF( LSAME( COMPQ, 'N' ) ) THEN
+         ILQ = .FALSE.
+         ICOMPQ = 1
+      ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 2
+      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+         ILQ = .TRUE.
+         ICOMPQ = 3
+      ELSE
+         ICOMPQ = 0
+      END IF
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ILZ = .FALSE.
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 2
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ILZ = .TRUE.
+         ICOMPZ = 3
+      ELSE
+         ICOMPZ = 0
+      END IF
+*
+*     Check Argument Values
+*
+      INFO = 0
+      WORK( 1 ) = MAX( 1, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( ISCHUR.EQ.0 ) THEN
+         INFO = -1
+      ELSE IF( ICOMPQ.EQ.0 ) THEN
+         INFO = -2
+      ELSE IF( ICOMPZ.EQ.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( ILO.LT.1 ) THEN
+         INFO = -5
+      ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+         INFO = -6
+      ELSE IF( LDH.LT.N ) THEN
+         INFO = -8
+      ELSE IF( LDT.LT.N ) THEN
+         INFO = -10
+      ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -14
+      ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -16
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -18
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZHGEQZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+*     WORK( 1 ) = CMPLX( 1 )
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = DCMPLX( 1 )
+         RETURN
+      END IF
+*
+*     Initialize Q and Z
+*
+      IF( ICOMPQ.EQ.3 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
+      IF( ICOMPZ.EQ.3 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+*     Machine Constants
+*
+      IN = IHI + 1 - ILO
+      SAFMIN = DLAMCH( 'S' )
+      ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
+      ANORM = ZLANHS( 'F', IN, H( ILO, ILO ), LDH, RWORK )
+      BNORM = ZLANHS( 'F', IN, T( ILO, ILO ), LDT, RWORK )
+      ATOL = MAX( SAFMIN, ULP*ANORM )
+      BTOL = MAX( SAFMIN, ULP*BNORM )
+      ASCALE = ONE / MAX( SAFMIN, ANORM )
+      BSCALE = ONE / MAX( SAFMIN, BNORM )
+*
+*
+*     Set Eigenvalues IHI+1:N
+*
+      DO 10 J = IHI + 1, N
+         ABSB = ABS( T( J, J ) )
+         IF( ABSB.GT.SAFMIN ) THEN
+            SIGNBC = DCONJG( T( J, J ) / ABSB )
+            T( J, J ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
+               CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
+            ELSE
+               H( J, J ) = H( J, J )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
+         ELSE
+            T( J, J ) = CZERO
+         END IF
+         ALPHA( J ) = H( J, J )
+         BETA( J ) = T( J, J )
+   10 CONTINUE
+*
+*     If IHI < ILO, skip QZ steps
+*
+      IF( IHI.LT.ILO )
+     $   GO TO 190
+*
+*     MAIN QZ ITERATION LOOP
+*
+*     Initialize dynamic indices
+*
+*     Eigenvalues ILAST+1:N have been found.
+*        Column operations modify rows IFRSTM:whatever
+*        Row operations modify columns whatever:ILASTM
+*
+*     If only eigenvalues are being computed, then
+*        IFRSTM is the row of the last splitting row above row ILAST;
+*        this is always at least ILO.
+*     IITER counts iterations since the last eigenvalue was found,
+*        to tell when to use an extraordinary shift.
+*     MAXIT is the maximum number of QZ sweeps allowed.
+*
+      ILAST = IHI
+      IF( ILSCHR ) THEN
+         IFRSTM = 1
+         ILASTM = N
+      ELSE
+         IFRSTM = ILO
+         ILASTM = IHI
+      END IF
+      IITER = 0
+      ESHIFT = CZERO
+      MAXIT = 30*( IHI-ILO+1 )
+*
+      DO 170 JITER = 1, MAXIT
+*
+*        Check for too many iterations.
+*
+         IF( JITER.GT.MAXIT )
+     $      GO TO 180
+*
+*        Split the matrix if possible.
+*
+*        Two tests:
+*           1: H(j,j-1)=0  or  j=ILO
+*           2: T(j,j)=0
+*
+*        Special case: j=ILAST
+*
+         IF( ILAST.EQ.ILO ) THEN
+            GO TO 60
+         ELSE
+            IF( ABS1( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
+               H( ILAST, ILAST-1 ) = CZERO
+               GO TO 60
+            END IF
+         END IF
+*
+         IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
+            T( ILAST, ILAST ) = CZERO
+            GO TO 50
+         END IF
+*
+*        General case: j<ILAST
+*
+         DO 40 J = ILAST - 1, ILO, -1
+*
+*           Test 1: for H(j,j-1)=0 or j=ILO
+*
+            IF( J.EQ.ILO ) THEN
+               ILAZRO = .TRUE.
+            ELSE
+               IF( ABS1( H( J, J-1 ) ).LE.ATOL ) THEN
+                  H( J, J-1 ) = CZERO
+                  ILAZRO = .TRUE.
+               ELSE
+                  ILAZRO = .FALSE.
+               END IF
+            END IF
+*
+*           Test 2: for T(j,j)=0
+*
+            IF( ABS( T( J, J ) ).LT.BTOL ) THEN
+               T( J, J ) = CZERO
+*
+*              Test 1a: Check for 2 consecutive small subdiagonals in A
+*
+               ILAZR2 = .FALSE.
+               IF( .NOT.ILAZRO ) THEN
+                  IF( ABS1( H( J, J-1 ) )*( ASCALE*ABS1( H( J+1,
+     $                J ) ) ).LE.ABS1( H( J, J ) )*( ASCALE*ATOL ) )
+     $                ILAZR2 = .TRUE.
+               END IF
+*
+*              If both tests pass (1 & 2), i.e., the leading diagonal
+*              element of B in the block is zero, split a 1x1 block off
+*              at the top. (I.e., at the J-th row/column) The leading
+*              diagonal element of the remainder can also be zero, so
+*              this may have to be done repeatedly.
+*
+               IF( ILAZRO .OR. ILAZR2 ) THEN
+                  DO 20 JCH = J, ILAST - 1
+                     CTEMP = H( JCH, JCH )
+                     CALL ZLARTG( CTEMP, H( JCH+1, JCH ), C, S,
+     $                            H( JCH, JCH ) )
+                     H( JCH+1, JCH ) = CZERO
+                     CALL ZROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+     $                          H( JCH+1, JCH+1 ), LDH, C, S )
+                     CALL ZROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+     $                          T( JCH+1, JCH+1 ), LDT, C, S )
+                     IF( ILQ )
+     $                  CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, DCONJG( S ) )
+                     IF( ILAZR2 )
+     $                  H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
+                     ILAZR2 = .FALSE.
+                     IF( ABS1( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
+                        IF( JCH+1.GE.ILAST ) THEN
+                           GO TO 60
+                        ELSE
+                           IFIRST = JCH + 1
+                           GO TO 70
+                        END IF
+                     END IF
+                     T( JCH+1, JCH+1 ) = CZERO
+   20             CONTINUE
+                  GO TO 50
+               ELSE
+*
+*                 Only test 2 passed -- chase the zero to T(ILAST,ILAST)
+*                 Then process as in the case T(ILAST,ILAST)=0
+*
+                  DO 30 JCH = J, ILAST - 1
+                     CTEMP = T( JCH, JCH+1 )
+                     CALL ZLARTG( CTEMP, T( JCH+1, JCH+1 ), C, S,
+     $                            T( JCH, JCH+1 ) )
+                     T( JCH+1, JCH+1 ) = CZERO
+                     IF( JCH.LT.ILASTM-1 )
+     $                  CALL ZROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+     $                             T( JCH+1, JCH+2 ), LDT, C, S )
+                     CALL ZROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+     $                          H( JCH+1, JCH-1 ), LDH, C, S )
+                     IF( ILQ )
+     $                  CALL ZROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+     $                             C, DCONJG( S ) )
+                     CTEMP = H( JCH+1, JCH )
+                     CALL ZLARTG( CTEMP, H( JCH+1, JCH-1 ), C, S,
+     $                            H( JCH+1, JCH ) )
+                     H( JCH+1, JCH-1 ) = CZERO
+                     CALL ZROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+     $                          H( IFRSTM, JCH-1 ), 1, C, S )
+                     CALL ZROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+     $                          T( IFRSTM, JCH-1 ), 1, C, S )
+                     IF( ILZ )
+     $                  CALL ZROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
+     $                             C, S )
+   30             CONTINUE
+                  GO TO 50
+               END IF
+            ELSE IF( ILAZRO ) THEN
+*
+*              Only test 1 passed -- work on J:ILAST
+*
+               IFIRST = J
+               GO TO 70
+            END IF
+*
+*           Neither test passed -- try next J
+*
+   40    CONTINUE
+*
+*        (Drop-through is "impossible")
+*
+         INFO = 2*N + 1
+         GO TO 210
+*
+*        T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
+*        1x1 block.
+*
+   50    CONTINUE
+         CTEMP = H( ILAST, ILAST )
+         CALL ZLARTG( CTEMP, H( ILAST, ILAST-1 ), C, S,
+     $                H( ILAST, ILAST ) )
+         H( ILAST, ILAST-1 ) = CZERO
+         CALL ZROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+     $              H( IFRSTM, ILAST-1 ), 1, C, S )
+         CALL ZROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+     $              T( IFRSTM, ILAST-1 ), 1, C, S )
+         IF( ILZ )
+     $      CALL ZROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
+*
+*        H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA
+*
+   60    CONTINUE
+         ABSB = ABS( T( ILAST, ILAST ) )
+         IF( ABSB.GT.SAFMIN ) THEN
+            SIGNBC = DCONJG( T( ILAST, ILAST ) / ABSB )
+            T( ILAST, ILAST ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL ZSCAL( ILAST-IFRSTM, SIGNBC, T( IFRSTM, ILAST ), 1 )
+               CALL ZSCAL( ILAST+1-IFRSTM, SIGNBC, H( IFRSTM, ILAST ),
+     $                     1 )
+            ELSE
+               H( ILAST, ILAST ) = H( ILAST, ILAST )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL ZSCAL( N, SIGNBC, Z( 1, ILAST ), 1 )
+         ELSE
+            T( ILAST, ILAST ) = CZERO
+         END IF
+         ALPHA( ILAST ) = H( ILAST, ILAST )
+         BETA( ILAST ) = T( ILAST, ILAST )
+*
+*        Go to next block -- exit if finished.
+*
+         ILAST = ILAST - 1
+         IF( ILAST.LT.ILO )
+     $      GO TO 190
+*
+*        Reset counters
+*
+         IITER = 0
+         ESHIFT = CZERO
+         IF( .NOT.ILSCHR ) THEN
+            ILASTM = ILAST
+            IF( IFRSTM.GT.ILAST )
+     $         IFRSTM = ILO
+         END IF
+         GO TO 160
+*
+*        QZ step
+*
+*        This iteration only involves rows/columns IFIRST:ILAST.  We
+*        assume IFIRST < ILAST, and that the diagonal of B is non-zero.
+*
+   70    CONTINUE
+         IITER = IITER + 1
+         IF( .NOT.ILSCHR ) THEN
+            IFRSTM = IFIRST
+         END IF
+*
+*        Compute the Shift.
+*
+*        At this point, IFIRST < ILAST, and the diagonal elements of
+*        T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
+*        magnitude)
+*
+         IF( ( IITER / 10 )*10.NE.IITER ) THEN
+*
+*           The Wilkinson shift (AEP p.512), i.e., the eigenvalue of
+*           the bottom-right 2x2 block of A inv(B) which is nearest to
+*           the bottom-right element.
+*
+*           We factor B as U*D, where U has unit diagonals, and
+*           compute (A*inv(D))*inv(U).
+*
+            U12 = ( BSCALE*T( ILAST-1, ILAST ) ) /
+     $            ( BSCALE*T( ILAST, ILAST ) )
+            AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
+     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
+            AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
+     $             ( BSCALE*T( ILAST-1, ILAST-1 ) )
+            AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
+     $             ( BSCALE*T( ILAST, ILAST ) )
+            AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
+     $             ( BSCALE*T( ILAST, ILAST ) )
+            ABI22 = AD22 - U12*AD21
+*
+            T1 = HALF*( AD11+ABI22 )
+            RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 )
+            TEMP = DBLE( T1-ABI22 )*DBLE( RTDISC ) +
+     $             DIMAG( T1-ABI22 )*DIMAG( RTDISC )
+            IF( TEMP.LE.ZERO ) THEN
+               SHIFT = T1 + RTDISC
+            ELSE
+               SHIFT = T1 - RTDISC
+            END IF
+         ELSE
+*
+*           Exceptional shift.  Chosen for no particularly good reason.
+*
+            ESHIFT = ESHIFT + DCONJG( ( ASCALE*H( ILAST-1, ILAST ) ) /
+     $               ( BSCALE*T( ILAST-1, ILAST-1 ) ) )
+            SHIFT = ESHIFT
+         END IF
+*
+*        Now check for two consecutive small subdiagonals.
+*
+         DO 80 J = ILAST - 1, IFIRST + 1, -1
+            ISTART = J
+            CTEMP = ASCALE*H( J, J ) - SHIFT*( BSCALE*T( J, J ) )
+            TEMP = ABS1( CTEMP )
+            TEMP2 = ASCALE*ABS1( H( J+1, J ) )
+            TEMPR = MAX( TEMP, TEMP2 )
+            IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+               TEMP = TEMP / TEMPR
+               TEMP2 = TEMP2 / TEMPR
+            END IF
+            IF( ABS1( H( J, J-1 ) )*TEMP2.LE.TEMP*ATOL )
+     $         GO TO 90
+   80    CONTINUE
+*
+         ISTART = IFIRST
+         CTEMP = ASCALE*H( IFIRST, IFIRST ) -
+     $           SHIFT*( BSCALE*T( IFIRST, IFIRST ) )
+   90    CONTINUE
+*
+*        Do an implicit-shift QZ sweep.
+*
+*        Initial Q
+*
+         CTEMP2 = ASCALE*H( ISTART+1, ISTART )
+         CALL ZLARTG( CTEMP, CTEMP2, C, S, CTEMP3 )
+*
+*        Sweep
+*
+         DO 150 J = ISTART, ILAST - 1
+            IF( J.GT.ISTART ) THEN
+               CTEMP = H( J, J-1 )
+               CALL ZLARTG( CTEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+               H( J+1, J-1 ) = CZERO
+            END IF
+*
+            DO 100 JC = J, ILASTM
+               CTEMP = C*H( J, JC ) + S*H( J+1, JC )
+               H( J+1, JC ) = -DCONJG( S )*H( J, JC ) + C*H( J+1, JC )
+               H( J, JC ) = CTEMP
+               CTEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+               T( J+1, JC ) = -DCONJG( S )*T( J, JC ) + C*T( J+1, JC )
+               T( J, JC ) = CTEMP2
+  100       CONTINUE
+            IF( ILQ ) THEN
+               DO 110 JR = 1, N
+                  CTEMP = C*Q( JR, J ) + DCONJG( S )*Q( JR, J+1 )
+                  Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+                  Q( JR, J ) = CTEMP
+  110          CONTINUE
+            END IF
+*
+            CTEMP = T( J+1, J+1 )
+            CALL ZLARTG( CTEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+            T( J+1, J ) = CZERO
+*
+            DO 120 JR = IFRSTM, MIN( J+2, ILAST )
+               CTEMP = C*H( JR, J+1 ) + S*H( JR, J )
+               H( JR, J ) = -DCONJG( S )*H( JR, J+1 ) + C*H( JR, J )
+               H( JR, J+1 ) = CTEMP
+  120       CONTINUE
+            DO 130 JR = IFRSTM, J
+               CTEMP = C*T( JR, J+1 ) + S*T( JR, J )
+               T( JR, J ) = -DCONJG( S )*T( JR, J+1 ) + C*T( JR, J )
+               T( JR, J+1 ) = CTEMP
+  130       CONTINUE
+            IF( ILZ ) THEN
+               DO 140 JR = 1, N
+                  CTEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+                  Z( JR, J ) = -DCONJG( S )*Z( JR, J+1 ) + C*Z( JR, J )
+                  Z( JR, J+1 ) = CTEMP
+  140          CONTINUE
+            END IF
+  150    CONTINUE
+*
+  160    CONTINUE
+*
+  170 CONTINUE
+*
+*     Drop-through = non-convergence
+*
+  180 CONTINUE
+      INFO = ILAST
+      GO TO 210
+*
+*     Successful completion of all QZ steps
+*
+  190 CONTINUE
+*
+*     Set Eigenvalues 1:ILO-1
+*
+      DO 200 J = 1, ILO - 1
+         ABSB = ABS( T( J, J ) )
+         IF( ABSB.GT.SAFMIN ) THEN
+            SIGNBC = DCONJG( T( J, J ) / ABSB )
+            T( J, J ) = ABSB
+            IF( ILSCHR ) THEN
+               CALL ZSCAL( J-1, SIGNBC, T( 1, J ), 1 )
+               CALL ZSCAL( J, SIGNBC, H( 1, J ), 1 )
+            ELSE
+               H( J, J ) = H( J, J )*SIGNBC
+            END IF
+            IF( ILZ )
+     $         CALL ZSCAL( N, SIGNBC, Z( 1, J ), 1 )
+         ELSE
+            T( J, J ) = CZERO
+         END IF
+         ALPHA( J ) = H( J, J )
+         BETA( J ) = T( J, J )
+  200 CONTINUE
+*
+*     Normal Termination
+*
+      INFO = 0
+*
+*     Exit (other than argument error) -- return optimal workspace size
+*
+  210 CONTINUE
+      WORK( 1 ) = DCMPLX( N )
+      RETURN
+*
+*     End of ZHGEQZ
+*
+      END
diff --git a/src/lib/lapack/zhseqr.f b/src/lib/lapack/zhseqr.f
new file mode 100644
index 00000000..fb721dad
--- /dev/null
+++ b/src/lib/lapack/zhseqr.f
@@ -0,0 +1,395 @@
+      SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDH, LDZ, LWORK, N
+      CHARACTER          COMPZ, JOB
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*     Purpose
+*     =======
+*
+*     ZHSEQR computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**H, where T is an upper triangular matrix (the
+*     Schur form), and Z is the unitary matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input unitary
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*
+*     Arguments
+*     =========
+*
+*     JOB   (input) CHARACTER*1
+*           = 'E':  compute eigenvalues only;
+*           = 'S':  compute eigenvalues and the Schur form T.
+*
+*     COMPZ (input) CHARACTER*1
+*           = 'N':  no Schur vectors are computed;
+*           = 'I':  Z is initialized to the unit matrix and the matrix Z
+*                   of Schur vectors of H is returned;
+*           = 'V':  Z must contain an unitary matrix Q on entry, and
+*                   the product Q*Z is returned.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+*           set by a previous call to ZGEBAL, and then passed to ZGEHRD
+*           when the matrix output by ZGEBAL is reduced to Hessenberg
+*           form. Otherwise ILO and IHI should be set to 1 and N
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and JOB = 'S', H contains the upper
+*           triangular matrix T from the Schur decomposition (the
+*           Schur form). If INFO = 0 and JOB = 'E', the contents of
+*           H are unspecified on exit.  (The output value of H when
+*           INFO.GT.0 is given under the description of INFO below.)
+*
+*           Unlike earlier versions of ZHSEQR, this subroutine may
+*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+*           or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     W        (output) COMPLEX*16 array, dimension (N)
+*           The computed eigenvalues. If JOB = 'S', the eigenvalues are
+*           stored in the same order as on the diagonal of the Schur
+*           form returned in H, with W(i) = H(i,i).
+*
+*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*           If COMPZ = 'N', Z is not referenced.
+*           If COMPZ = 'I', on entry Z need not be set and on exit,
+*           if INFO = 0, Z contains the unitary matrix Z of the Schur
+*           vectors of H.  If COMPZ = 'V', on entry Z must contain an
+*           N-by-N matrix Q, which is assumed to be equal to the unit
+*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+*           if INFO = 0, Z contains Q*Z.
+*           Normally Q is the unitary matrix generated by ZUNGHR
+*           after the call to ZGEHRD which formed the Hessenberg matrix
+*           H. (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if COMPZ = 'I' or
+*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) COMPLEX*16 array, dimension (LWORK)
+*           On exit, if INFO = 0, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then ZHSEQR does a workspace query.
+*           In this case, ZHSEQR checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .LT. 0:  if INFO = -i, the i-th argument had an illegal
+*                    value
+*           .GT. 0:  if INFO = i, ZHSEQR failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and JOB = 'E', then on exit, the
+*                remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and JOB   = 'S', then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is a unitary matrix.  The final
+*                value of  H is upper Hessenberg and triangular in
+*                rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and COMPZ = 'V', then on exit
+*
+*                  (final value of Z)  =  (initial value of Z)*U
+*
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'I', then on exit
+*                      (final value of Z)  = U
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of JOB.)
+*
+*                If INFO .GT. 0 and COMPZ = 'N', then Z is not
+*                accessed.
+*
+*     ================================================================
+*             Default values supplied by
+*             ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+*             It is suggested that these defaults be adjusted in order
+*             to attain best performance in each particular
+*             computational environment.
+*
+*            ISPEC=1:  The ZLAHQR vs ZLAQR0 crossover point.
+*                      Default: 75. (Must be at least 11.)
+*
+*            ISPEC=2:  Recommended deflation window size.
+*                      This depends on ILO, IHI and NS.  NS is the
+*                      number of simultaneous shifts returned
+*                      by ILAENV(ISPEC=4).  (See ISPEC=4 below.)
+*                      The default for (IHI-ILO+1).LE.500 is NS.
+*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+*            ISPEC=3:  Nibble crossover point. (See ILAENV for
+*                      details.)  Default: 14% of deflation window
+*                      size.
+*
+*            ISPEC=4:  Number of simultaneous shifts, NS, in
+*                      a multi-shift QR iteration.
+*
+*                      If IHI-ILO+1 is ...
+*
+*                      greater than      ...but less    ... the
+*                      or equal to ...      than        default is
+*
+*                           1               30          NS -   2(+)
+*                          30               60          NS -   4(+)
+*                          60              150          NS =  10(+)
+*                         150              590          NS =  **
+*                         590             3000          NS =  64
+*                        3000             6000          NS = 128
+*                        6000             infinity      NS = 256
+*
+*                  (+)  By default some or all matrices of this order 
+*                       are passed to the implicit double shift routine
+*                       ZLAHQR and NS is ignored.  See ISPEC=1 above 
+*                       and comments in IPARM for details.
+*
+*                       The asterisks (**) indicate an ad-hoc
+*                       function of N increasing from 10 to 64.
+*
+*            ISPEC=5:  Select structured matrix multiply.
+*                      (See ILAENV for details.) Default: 3.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    ZLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== NL allocates some local workspace to help small matrices
+*     .    through a rare ZLAHQR failure.  NL .GT. NTINY = 11 is
+*     .    required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
+*     .    mended.  (The default value of NMIN is 75.)  Using NL = 49
+*     .    allows up to six simultaneous shifts and a 16-by-16
+*     .    deflation window.  ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            NL
+      PARAMETER          ( NL = 49 )
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO
+      PARAMETER          ( RZERO = 0.0d0 )
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         HL( NL, NL ), WORKL( NL )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            KBOT, NMIN
+      LOGICAL            INITZ, LQUERY, WANTT, WANTZ
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      LOGICAL            LSAME
+      EXTERNAL           ILAENV, LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZLACPY, ZLAHQR, ZLAQR0, ZLASET
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Decode and check the input parameters. ====
+*
+      WANTT = LSAME( JOB, 'S' )
+      INITZ = LSAME( COMPZ, 'I' )
+      WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+      WORK( 1 ) = DCMPLX( DBLE( MAX( 1, N ) ), RZERO )
+      LQUERY = LWORK.EQ.-1
+*
+      INFO = 0
+      IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -5
+      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+*
+*        ==== Quick return in case of invalid argument. ====
+*
+         CALL XERBLA( 'ZHSEQR', -INFO )
+         RETURN
+*
+      ELSE IF( N.EQ.0 ) THEN
+*
+*        ==== Quick return in case N = 0; nothing to do. ====
+*
+         RETURN
+*
+      ELSE IF( LQUERY ) THEN
+*
+*        ==== Quick return in case of a workspace query ====
+*
+         CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI, Z,
+     $                LDZ, WORK, LWORK, INFO )
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+         WORK( 1 ) = DCMPLX( MAX( DBLE( WORK( 1 ) ), DBLE( MAX( 1,
+     $               N ) ) ), RZERO )
+         RETURN
+*
+      ELSE
+*
+*        ==== copy eigenvalues isolated by ZGEBAL ====
+*
+         IF( ILO.GT.1 )
+     $      CALL ZCOPY( ILO-1, H, LDH+1, W, 1 )
+         IF( IHI.LT.N )
+     $      CALL ZCOPY( N-IHI, H( IHI+1, IHI+1 ), LDH+1, W( IHI+1 ), 1 )
+*
+*        ==== Initialize Z, if requested ====
+*
+         IF( INITZ )
+     $      CALL ZLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+*        ==== Quick return if possible ====
+*
+         IF( ILO.EQ.IHI ) THEN
+            W( ILO ) = H( ILO, ILO )
+            RETURN
+         END IF
+*
+*        ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
+     $          IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== ZLAQR0 for big matrices; ZLAHQR for small ones ====
+*
+         IF( N.GT.NMIN ) THEN
+            CALL ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, WORK, LWORK, INFO )
+         ELSE
+*
+*           ==== Small matrix ====
+*
+            CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILO, IHI,
+     $                   Z, LDZ, INFO )
+*
+            IF( INFO.GT.0 ) THEN
+*
+*              ==== A rare ZLAHQR failure!  ZLAQR0 sometimes succeeds
+*              .    when ZLAHQR fails. ====
+*
+               KBOT = INFO
+*
+               IF( N.GE.NL ) THEN
+*
+*                 ==== Larger matrices have enough subdiagonal scratch
+*                 .    space to call ZLAQR0 directly. ====
+*
+                  CALL ZLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, W,
+     $                         ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
+*
+               ELSE
+*
+*                 ==== Tiny matrices don't have enough subdiagonal
+*                 .    scratch space to benefit from ZLAQR0.  Hence,
+*                 .    tiny matrices must be copied into a larger
+*                 .    array before calling ZLAQR0. ====
+*
+                  CALL ZLACPY( 'A', N, N, H, LDH, HL, NL )
+                  HL( N+1, N ) = ZERO
+                  CALL ZLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+     $                         NL )
+                  CALL ZLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, W,
+     $                         ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+                  IF( WANTT .OR. INFO.NE.0 )
+     $               CALL ZLACPY( 'A', N, N, HL, NL, H, LDH )
+               END IF
+            END IF
+         END IF
+*
+*        ==== Clear out the trash, if necessary. ====
+*
+         IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+     $      CALL ZLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+*        ==== Ensure reported workspace size is backward-compatible with
+*        .    previous LAPACK versions. ====
+*
+         WORK( 1 ) = DCMPLX( MAX( DBLE( MAX( 1, N ) ),
+     $               DBLE( WORK( 1 ) ) ), RZERO )
+      END IF
+*
+*     ==== End of ZHSEQR ====
+*
+      END
diff --git a/src/lib/lapack/zlabrd.f b/src/lib/lapack/zlabrd.f
new file mode 100644
index 00000000..fb482c84
--- /dev/null
+++ b/src/lib/lapack/zlabrd.f
@@ -0,0 +1,328 @@
+      SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+     $                   LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, LDX, LDY, M, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * )
+      COMPLEX*16         A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
+     $                   Y( LDY, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLABRD reduces the first NB rows and columns of a complex general
+*  m by n matrix A to upper or lower real bidiagonal form by a unitary
+*  transformation Q' * A * P, and returns the matrices X and Y which
+*  are needed to apply the transformation to the unreduced part of A.
+*
+*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
+*  bidiagonal form.
+*
+*  This is an auxiliary routine called by ZGEBRD
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows in the matrix A.
+*
+*  N       (input) INTEGER
+*          The number of columns in the matrix A.
+*
+*  NB      (input) INTEGER
+*          The number of leading rows and columns of A to be reduced.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n general matrix to be reduced.
+*          On exit, the first NB rows and columns of the matrix are
+*          overwritten; the rest of the array is unchanged.
+*          If m >= n, elements on and below the diagonal in the first NB
+*            columns, with the array TAUQ, represent the unitary
+*            matrix Q as a product of elementary reflectors; and
+*            elements above the diagonal in the first NB rows, with the
+*            array TAUP, represent the unitary matrix P as a product
+*            of elementary reflectors.
+*          If m < n, elements below the diagonal in the first NB
+*            columns, with the array TAUQ, represent the unitary
+*            matrix Q as a product of elementary reflectors, and
+*            elements on and above the diagonal in the first NB rows,
+*            with the array TAUP, represent the unitary matrix P as
+*            a product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  D       (output) DOUBLE PRECISION array, dimension (NB)
+*          The diagonal elements of the first NB rows and columns of
+*          the reduced matrix.  D(i) = A(i,i).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (NB)
+*          The off-diagonal elements of the first NB rows and columns of
+*          the reduced matrix.
+*
+*  TAUQ    (output) COMPLEX*16 array dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix Q. See Further Details.
+*
+*  TAUP    (output) COMPLEX*16 array, dimension (NB)
+*          The scalar factors of the elementary reflectors which
+*          represent the unitary matrix P. See Further Details.
+*
+*  X       (output) COMPLEX*16 array, dimension (LDX,NB)
+*          The m-by-nb matrix X required to update the unreduced part
+*          of A.
+*
+*  LDX     (input) INTEGER
+*          The leading dimension of the array X. LDX >= max(1,M).
+*
+*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)
+*          The n-by-nb matrix Y required to update the unreduced part
+*          of A.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  The matrices Q and P are represented as products of elementary
+*  reflectors:
+*
+*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
+*
+*  Each H(i) and G(i) has the form:
+*
+*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
+*
+*  where tauq and taup are complex scalars, and v and u are complex
+*  vectors.
+*
+*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
+*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
+*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
+*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
+*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+*  The elements of the vectors v and u together form the m-by-nb matrix
+*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
+*  the transformation to the unreduced part of the matrix, using a block
+*  update of the form:  A := A - V*Y' - X*U'.
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with nb = 2:
+*
+*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
+*
+*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
+*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
+*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
+*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
+*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
+*    (  v1  v2  a   a   a  )
+*
+*  where a denotes an element of the original matrix which is unchanged,
+*  vi denotes an element of the vector defining H(i), and ui an element
+*  of the vector defining G(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZLACGV, ZLARFG, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( M.GE.N ) THEN
+*
+*        Reduce to upper bidiagonal form
+*
+         DO 10 I = 1, NB
+*
+*           Update A(i:m,i)
+*
+            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
+            CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+            CALL ZLACGV( I-1, Y( I, 1 ), LDY )
+            CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
+     $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
+*
+*           Generate reflection Q(i) to annihilate A(i+1:m,i)
+*
+            ALPHA = A( I, I )
+            CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
+     $                   TAUQ( I ) )
+            D( I ) = ALPHA
+            IF( I.LT.N ) THEN
+               A( I, I ) = ONE
+*
+*              Compute Y(i+1:n,i)
+*
+               CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
+     $                     A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
+     $                     Y( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
+     $                     A( I, 1 ), LDA, A( I, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
+     $                     X( I, 1 ), LDX, A( I, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
+     $                     Y( I+1, I ), 1 )
+               CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+*              Update A(i,i+1:n)
+*
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               CALL ZLACGV( I, A( I, 1 ), LDA )
+               CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+     $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+               CALL ZLACGV( I, A( I, 1 ), LDA )
+               CALL ZLACGV( I-1, X( I, 1 ), LDX )
+               CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
+     $                     A( I, I+1 ), LDA )
+               CALL ZLACGV( I-1, X( I, 1 ), LDX )
+*
+*              Generate reflection P(i) to annihilate A(i,i+2:n)
+*
+               ALPHA = A( I, I+1 )
+               CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
+     $                      TAUP( I ) )
+               E( I ) = ALPHA
+               A( I, I+1 ) = ONE
+*
+*              Compute X(i+1:m,i)
+*
+               CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
+     $                     Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
+     $                     X( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+     $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Reduce to lower bidiagonal form
+*
+         DO 20 I = 1, NB
+*
+*           Update A(i,i:n)
+*
+            CALL ZLACGV( N-I+1, A( I, I ), LDA )
+            CALL ZLACGV( I-1, A( I, 1 ), LDA )
+            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+     $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+            CALL ZLACGV( I-1, A( I, 1 ), LDA )
+            CALL ZLACGV( I-1, X( I, 1 ), LDX )
+            CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
+     $                  A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
+     $                  LDA )
+            CALL ZLACGV( I-1, X( I, 1 ), LDX )
+*
+*           Generate reflection P(i) to annihilate A(i,i+1:n)
+*
+            ALPHA = A( I, I )
+            CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
+     $                   TAUP( I ) )
+            D( I ) = ALPHA
+            IF( I.LT.M ) THEN
+               A( I, I ) = ONE
+*
+*              Compute X(i+1:m,i)
+*
+               CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
+     $                     Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
+     $                     X( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+     $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+     $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+               CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+               CALL ZLACGV( N-I+1, A( I, I ), LDA )
+*
+*              Update A(i+1:m,i)
+*
+               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
+               CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+               CALL ZLACGV( I-1, Y( I, 1 ), LDY )
+               CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
+     $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
+*
+*              Generate reflection Q(i) to annihilate A(i+2:m,i)
+*
+               ALPHA = A( I+1, I )
+               CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
+     $                      TAUQ( I ) )
+               E( I ) = ALPHA
+               A( I+1, I ) = ONE
+*
+*              Compute Y(i+1:n,i)
+*
+               CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
+     $                     A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
+     $                     Y( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+     $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
+     $                     X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
+     $                     Y( 1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
+     $                     A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
+     $                     Y( I+1, I ), 1 )
+               CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+            ELSE
+               CALL ZLACGV( N-I+1, A( I, I ), LDA )
+            END IF
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZLABRD
+*
+      END
diff --git a/src/lib/lapack/zlacgv.f b/src/lib/lapack/zlacgv.f
new file mode 100644
index 00000000..0033e306
--- /dev/null
+++ b/src/lib/lapack/zlacgv.f
@@ -0,0 +1,60 @@
+      SUBROUTINE ZLACGV( N, X, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACGV conjugates a complex vector of length N.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The length of the vector X.  N >= 0.
+*
+*  X       (input/output) COMPLEX*16 array, dimension
+*                         (1+(N-1)*abs(INCX))
+*          On entry, the vector of length N to be conjugated.
+*          On exit, X is overwritten with conjg(X).
+*
+*  INCX    (input) INTEGER
+*          The spacing between successive elements of X.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IOFF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( INCX.EQ.1 ) THEN
+         DO 10 I = 1, N
+            X( I ) = DCONJG( X( I ) )
+   10    CONTINUE
+      ELSE
+         IOFF = 1
+         IF( INCX.LT.0 )
+     $      IOFF = 1 - ( N-1 )*INCX
+         DO 20 I = 1, N
+            X( IOFF ) = DCONJG( X( IOFF ) )
+            IOFF = IOFF + INCX
+   20    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZLACGV
+*
+      END
diff --git a/src/lib/lapack/zlacn2.f b/src/lib/lapack/zlacn2.f
new file mode 100644
index 00000000..99f7ae35
--- /dev/null
+++ b/src/lib/lapack/zlacn2.f
@@ -0,0 +1,221 @@
+      SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KASE, N
+      DOUBLE PRECISION   EST
+*     ..
+*     .. Array Arguments ..
+      INTEGER            ISAVE( 3 )
+      COMPLEX*16         V( * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACN2 estimates the 1-norm of a square, complex matrix A.
+*  Reverse communication is used for evaluating matrix-vector products.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The order of the matrix.  N >= 1.
+*
+*  V      (workspace) COMPLEX*16 array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) COMPLEX*16 array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         where A' is the conjugate transpose of A, and ZLACN2 must be
+*         re-called with all the other parameters unchanged.
+*
+*  EST    (input/output) DOUBLE PRECISION
+*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+*         unchanged from the previous call to ZLACN2.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to ZLACN2, KASE should be 0.
+*         On an intermediate return, KASE will be 1 or 2, indicating
+*         whether X should be overwritten by A * X  or A' * X.
+*         On the final return from ZLACN2, KASE will again be 0.
+*
+*  ISAVE  (input/output) INTEGER array, dimension (3)
+*         ISAVE is used to save variables between calls to ZLACN2
+*
+*  Further Details
+*  ======= =======
+*
+*  Contributed by Nick Higham, University of Manchester.
+*  Originally named CONEST, dated March 16, 1988.
+*
+*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+*  a real or complex matrix, with applications to condition estimation",
+*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+*  Last modified:  April, 1999
+*
+*  This is a thread safe version of ZLACON, which uses the array ISAVE
+*  in place of a SAVE statement, as follows:
+*
+*     ZLACON     ZLACN2
+*      JUMP     ISAVE(1)
+*      J        ISAVE(2)
+*      ITER     ISAVE(3)
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER              ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION     ONE,         TWO
+      PARAMETER          ( ONE = 1.0D0, TWO = 2.0D0 )
+      COMPLEX*16           CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                            CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, JLAST
+      DOUBLE PRECISION   ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            IZMAX1
+      DOUBLE PRECISION   DLAMCH, DZSUM1
+      EXTERNAL           IZMAX1, DLAMCH, DZSUM1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = DCMPLX( ONE / DBLE( N ) )
+   10    CONTINUE
+         KASE = 1
+         ISAVE( 1 ) = 1
+         RETURN
+      END IF
+*
+      GO TO ( 20, 40, 70, 90, 120 )ISAVE( 1 )
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 1)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
+*
+   20 CONTINUE
+      IF( N.EQ.1 ) THEN
+         V( 1 ) = X( 1 )
+         EST = ABS( V( 1 ) )
+*        ... QUIT
+         GO TO 130
+      END IF
+      EST = DZSUM1( N, X, 1 )
+*
+      DO 30 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
+     $               DIMAG( X( I ) ) / ABSXI )
+         ELSE
+            X( I ) = CONE
+         END IF
+   30 CONTINUE
+      KASE = 2
+      ISAVE( 1 ) = 2
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 2)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
+*
+   40 CONTINUE
+      ISAVE( 2 ) = IZMAX1( N, X, 1 )
+      ISAVE( 3 ) = 2
+*
+*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+   50 CONTINUE
+      DO 60 I = 1, N
+         X( I ) = CZERO
+   60 CONTINUE
+      X( ISAVE( 2 ) ) = CONE
+      KASE = 1
+      ISAVE( 1 ) = 3
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 3)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+   70 CONTINUE
+      CALL ZCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = DZSUM1( N, V, 1 )
+*
+*     TEST FOR CYCLING.
+      IF( EST.LE.ESTOLD )
+     $   GO TO 100
+*
+      DO 80 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
+     $               DIMAG( X( I ) ) / ABSXI )
+         ELSE
+            X( I ) = CONE
+         END IF
+   80 CONTINUE
+      KASE = 2
+      ISAVE( 1 ) = 4
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 4)
+*     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
+*
+   90 CONTINUE
+      JLAST = ISAVE( 2 )
+      ISAVE( 2 ) = IZMAX1( N, X, 1 )
+      IF( ( ABS( X( JLAST ) ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
+     $    ( ISAVE( 3 ).LT.ITMAX ) ) THEN
+         ISAVE( 3 ) = ISAVE( 3 ) + 1
+         GO TO 50
+      END IF
+*
+*     ITERATION COMPLETE.  FINAL STAGE.
+*
+  100 CONTINUE
+      ALTSGN = ONE
+      DO 110 I = 1, N
+         X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) )
+         ALTSGN = -ALTSGN
+  110 CONTINUE
+      KASE = 1
+      ISAVE( 1 ) = 5
+      RETURN
+*
+*     ................ ENTRY   (ISAVE( 1 ) = 5)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+  120 CONTINUE
+      TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL ZCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  130 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of ZLACN2
+*
+      END
diff --git a/src/lib/lapack/zlacon.f b/src/lib/lapack/zlacon.f
new file mode 100644
index 00000000..5773ef92
--- /dev/null
+++ b/src/lib/lapack/zlacon.f
@@ -0,0 +1,212 @@
+      SUBROUTINE ZLACON( N, V, X, EST, KASE )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KASE, N
+      DOUBLE PRECISION   EST
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         V( N ), X( N )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACON estimates the 1-norm of a square, complex matrix A.
+*  Reverse communication is used for evaluating matrix-vector products.
+*
+*  Arguments
+*  =========
+*
+*  N      (input) INTEGER
+*         The order of the matrix.  N >= 1.
+*
+*  V      (workspace) COMPLEX*16 array, dimension (N)
+*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
+*         (W is not returned).
+*
+*  X      (input/output) COMPLEX*16 array, dimension (N)
+*         On an intermediate return, X should be overwritten by
+*               A * X,   if KASE=1,
+*               A' * X,  if KASE=2,
+*         where A' is the conjugate transpose of A, and ZLACON must be
+*         re-called with all the other parameters unchanged.
+*
+*  EST    (input/output) DOUBLE PRECISION
+*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+*         unchanged from the previous call to ZLACON.
+*         On exit, EST is an estimate (a lower bound) for norm(A). 
+*
+*  KASE   (input/output) INTEGER
+*         On the initial call to ZLACON, KASE should be 0.
+*         On an intermediate return, KASE will be 1 or 2, indicating
+*         whether X should be overwritten by A * X  or A' * X.
+*         On the final return from ZLACON, KASE will again be 0.
+*
+*  Further Details
+*  ======= =======
+*
+*  Contributed by Nick Higham, University of Manchester.
+*  Originally named CONEST, dated March 16, 1988.
+*
+*  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+*  a real or complex matrix, with applications to condition estimation",
+*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+*  Last modified:  April, 1999
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 5 )
+      DOUBLE PRECISION   ONE, TWO
+      PARAMETER          ( ONE = 1.0D0, TWO = 2.0D0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITER, J, JLAST, JUMP
+      DOUBLE PRECISION   ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
+*     ..
+*     .. External Functions ..
+      INTEGER            IZMAX1
+      DOUBLE PRECISION   DLAMCH, DZSUM1
+      EXTERNAL           IZMAX1, DLAMCH, DZSUM1
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG
+*     ..
+*     .. Save statement ..
+      SAVE
+*     ..
+*     .. Executable Statements ..
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      IF( KASE.EQ.0 ) THEN
+         DO 10 I = 1, N
+            X( I ) = DCMPLX( ONE / DBLE( N ) )
+   10    CONTINUE
+         KASE = 1
+         JUMP = 1
+         RETURN
+      END IF
+*
+      GO TO ( 20, 40, 70, 90, 120 )JUMP
+*
+*     ................ ENTRY   (JUMP = 1)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
+*
+   20 CONTINUE
+      IF( N.EQ.1 ) THEN
+         V( 1 ) = X( 1 )
+         EST = ABS( V( 1 ) )
+*        ... QUIT
+         GO TO 130
+      END IF
+      EST = DZSUM1( N, X, 1 )
+*
+      DO 30 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
+     $               DIMAG( X( I ) ) / ABSXI )
+         ELSE
+            X( I ) = CONE
+         END IF
+   30 CONTINUE
+      KASE = 2
+      JUMP = 2
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 2)
+*     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
+*
+   40 CONTINUE
+      J = IZMAX1( N, X, 1 )
+      ITER = 2
+*
+*     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+   50 CONTINUE
+      DO 60 I = 1, N
+         X( I ) = CZERO
+   60 CONTINUE
+      X( J ) = CONE
+      KASE = 1
+      JUMP = 3
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 3)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+   70 CONTINUE
+      CALL ZCOPY( N, X, 1, V, 1 )
+      ESTOLD = EST
+      EST = DZSUM1( N, V, 1 )
+*
+*     TEST FOR CYCLING.
+      IF( EST.LE.ESTOLD )
+     $   GO TO 100
+*
+      DO 80 I = 1, N
+         ABSXI = ABS( X( I ) )
+         IF( ABSXI.GT.SAFMIN ) THEN
+            X( I ) = DCMPLX( DBLE( X( I ) ) / ABSXI,
+     $               DIMAG( X( I ) ) / ABSXI )
+         ELSE
+            X( I ) = CONE
+         END IF
+   80 CONTINUE
+      KASE = 2
+      JUMP = 4
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 4)
+*     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
+*
+   90 CONTINUE
+      JLAST = J
+      J = IZMAX1( N, X, 1 )
+      IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND.
+     $    ( ITER.LT.ITMAX ) ) THEN
+         ITER = ITER + 1
+         GO TO 50
+      END IF
+*
+*     ITERATION COMPLETE.  FINAL STAGE.
+*
+  100 CONTINUE
+      ALTSGN = ONE
+      DO 110 I = 1, N
+         X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) )
+         ALTSGN = -ALTSGN
+  110 CONTINUE
+      KASE = 1
+      JUMP = 5
+      RETURN
+*
+*     ................ ENTRY   (JUMP = 5)
+*     X HAS BEEN OVERWRITTEN BY A*X.
+*
+  120 CONTINUE
+      TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) )
+      IF( TEMP.GT.EST ) THEN
+         CALL ZCOPY( N, X, 1, V, 1 )
+         EST = TEMP
+      END IF
+*
+  130 CONTINUE
+      KASE = 0
+      RETURN
+*
+*     End of ZLACON
+*
+      END
diff --git a/src/lib/lapack/zlacpy.f b/src/lib/lapack/zlacpy.f
new file mode 100644
index 00000000..8878311a
--- /dev/null
+++ b/src/lib/lapack/zlacpy.f
@@ -0,0 +1,90 @@
+      SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, LDB, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLACPY copies all or part of a two-dimensional matrix A to another
+*  matrix B.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the part of the matrix A to be copied to B.
+*          = 'U':      Upper triangular part
+*          = 'L':      Lower triangular part
+*          Otherwise:  All of the matrix A
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The m by n matrix A.  If UPLO = 'U', only the upper trapezium
+*          is accessed; if UPLO = 'L', only the lower trapezium is
+*          accessed.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  B       (output) COMPLEX*16 array, dimension (LDB,N)
+*          On exit, B = A in the locations specified by UPLO.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B.  LDB >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+         DO 20 J = 1, N
+            DO 10 I = 1, MIN( J, M )
+               B( I, J ) = A( I, J )
+   10       CONTINUE
+   20    CONTINUE
+*
+      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+         DO 40 J = 1, N
+            DO 30 I = J, M
+               B( I, J ) = A( I, J )
+   30       CONTINUE
+   40    CONTINUE
+*
+      ELSE
+         DO 60 J = 1, N
+            DO 50 I = 1, M
+               B( I, J ) = A( I, J )
+   50       CONTINUE
+   60    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLACPY
+*
+      END
diff --git a/src/lib/lapack/zladiv.f b/src/lib/lapack/zladiv.f
new file mode 100644
index 00000000..4a12055e
--- /dev/null
+++ b/src/lib/lapack/zladiv.f
@@ -0,0 +1,46 @@
+      COMPLEX*16     FUNCTION ZLADIV( X, Y )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      COMPLEX*16         X, Y
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLADIV := X / Y, where X and Y are complex.  The computation of X / Y
+*  will not overflow on an intermediary step unless the results
+*  overflows.
+*
+*  Arguments
+*  =========
+*
+*  X       (input) COMPLEX*16
+*  Y       (input) COMPLEX*16
+*          The complex scalars X and Y.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      DOUBLE PRECISION   ZI, ZR
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, DIMAG
+*     ..
+*     .. Executable Statements ..
+*
+      CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR,
+     $             ZI )
+      ZLADIV = DCMPLX( ZR, ZI )
+*
+      RETURN
+*
+*     End of ZLADIV
+*
+      END
diff --git a/src/lib/lapack/zlahqr.f b/src/lib/lapack/zlahqr.f
new file mode 100644
index 00000000..9ce9be19
--- /dev/null
+++ b/src/lib/lapack/zlahqr.f
@@ -0,0 +1,470 @@
+      SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     ZLAHQR is an auxiliary routine called by CHSEQR to update the
+*     eigenvalues and Schur decomposition already computed by CHSEQR, by
+*     dealing with the Hessenberg submatrix in rows and columns ILO to
+*     IHI.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H.  N >= 0.
+*
+*     ILO     (input) INTEGER
+*     IHI     (input) INTEGER
+*          It is assumed that H is already upper triangular in rows and
+*          columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).
+*          ZLAHQR works primarily with the Hessenberg submatrix in rows
+*          and columns ILO to IHI, but applies transformations to all of
+*          H if WANTT is .TRUE..
+*          1 <= ILO <= max(1,IHI); IHI <= N.
+*
+*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)
+*          On entry, the upper Hessenberg matrix H.
+*          On exit, if INFO is zero and if WANTT is .TRUE., then H
+*          is upper triangular in rows and columns ILO:IHI.  If INFO
+*          is zero and if WANTT is .FALSE., then the contents of H
+*          are unspecified on exit.  The output state of H in case
+*          INF is positive is below under the description of INFO.
+*
+*     LDH     (input) INTEGER
+*          The leading dimension of the array H. LDH >= max(1,N).
+*
+*     W       (output) COMPLEX*16 array, dimension (N)
+*          The computed eigenvalues ILO to IHI are stored in the
+*          corresponding elements of W. If WANTT is .TRUE., the
+*          eigenvalues are stored in the same order as on the diagonal
+*          of the Schur form returned in H, with W(i) = H(i,i).
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE..
+*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          If WANTZ is .TRUE., on entry Z must contain the current
+*          matrix Z of transformations accumulated by CHSEQR, and on
+*          exit Z has been updated; transformations are applied only to
+*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).
+*          If WANTZ is .FALSE., Z is not referenced.
+*
+*     LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= max(1,N).
+*
+*     INFO    (output) INTEGER
+*           =   0: successful exit
+*          .GT. 0: if INFO = i, ZLAHQR failed to compute all the
+*                  eigenvalues ILO to IHI in a total of 30 iterations
+*                  per eigenvalue; elements i+1:ihi of W contain
+*                  those eigenvalues which have been successfully
+*                  computed.
+*
+*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,
+*                  the remaining unconverged eigenvalues are the
+*                  eigenvalues of the upper Hessenberg matrix
+*                  rows and columns ILO thorugh INFO of the final,
+*                  output value of H.
+*
+*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*          (*)       (initial value of H)*U  = U*(final value of H)
+*                  where U is an orthognal matrix.    The final
+*                  value of H is upper Hessenberg and triangular in
+*                  rows and columns INFO+1 through IHI.
+*
+*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*                      (final value of Z)  = (initial value of Z)*U
+*                  where U is the orthogonal matrix in (*)
+*                  (regardless of the value of WANTT.)
+*
+*     Further Details
+*     ===============
+*
+*     02-96 Based on modifications by
+*     David Day, Sandia National Laboratory, USA
+*
+*     12-04 Further modifications by
+*     Ralph Byers, University of Kansas, USA
+*
+*       This is a modified version of ZLAHQR from LAPACK version 3.0.
+*       It is (1) more robust against overflow and underflow and
+*       (2) adopts the more conservative Ahues & Tisseur stopping
+*       criterion (LAWN 122, 1997).
+*
+*     =========================================================
+*
+*     .. Parameters ..
+      INTEGER            ITMAX
+      PARAMETER          ( ITMAX = 30 )
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO, RONE, HALF
+      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0, HALF = 0.5d0 )
+      DOUBLE PRECISION   DAT1
+      PARAMETER          ( DAT1 = 3.0d0 / 4.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         CDUM, H11, H11S, H22, SC, SUM, T, T1, TEMP, U,
+     $                   V2, X, Y
+      DOUBLE PRECISION   AA, AB, BA, BB, H10, H21, RTEMP, S, SAFMAX,
+     $                   SAFMIN, SMLNUM, SX, T2, TST, ULP
+      INTEGER            I, I1, I2, ITS, J, JHI, JLO, K, L, M, NH, NZ
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         V( 2 )
+*     ..
+*     .. External Functions ..
+      COMPLEX*16         ZLADIV
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           ZLADIV, DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZCOPY, ZLARFG, ZSCAL
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+      IF( ILO.EQ.IHI ) THEN
+         W( ILO ) = H( ILO, ILO )
+         RETURN
+      END IF
+*
+*     ==== clear out the trash ====
+      DO 10 J = ILO, IHI - 3
+         H( J+2, J ) = ZERO
+         H( J+3, J ) = ZERO
+   10 CONTINUE
+      IF( ILO.LE.IHI-2 )
+     $   H( IHI, IHI-2 ) = ZERO
+*     ==== ensure that subdiagonal entries are real ====
+      DO 20 I = ILO + 1, IHI
+         IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN
+*           ==== The following redundant normalization
+*           .    avoids problems with both gradual and
+*           .    sudden underflow in ABS(H(I,I-1)) ====
+            SC = H( I, I-1 ) / CABS1( H( I, I-1 ) )
+            SC = DCONJG( SC ) / ABS( SC )
+            H( I, I-1 ) = ABS( H( I, I-1 ) )
+            IF( WANTT ) THEN
+               JLO = 1
+               JHI = N
+            ELSE
+               JLO = ILO
+               JHI = IHI
+            END IF
+            CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH )
+            CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ),
+     $                  H( JLO, I ), 1 )
+            IF( WANTZ )
+     $         CALL ZSCAL( IHIZ-ILOZ+1, DCONJG( SC ), Z( ILOZ, I ), 1 )
+         END IF
+   20 CONTINUE
+*
+      NH = IHI - ILO + 1
+      NZ = IHIZ - ILOZ + 1
+*
+*     Set machine-dependent constants for the stopping criterion.
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
+*
+*     I1 and I2 are the indices of the first row and last column of H
+*     to which transformations must be applied. If eigenvalues only are
+*     being computed, I1 and I2 are set inside the main loop.
+*
+      IF( WANTT ) THEN
+         I1 = 1
+         I2 = N
+      END IF
+*
+*     The main loop begins here. I is the loop index and decreases from
+*     IHI to ILO in steps of 1. Each iteration of the loop works
+*     with the active submatrix in rows and columns L to I.
+*     Eigenvalues I+1 to IHI have already converged. Either L = ILO, or
+*     H(L,L-1) is negligible so that the matrix splits.
+*
+      I = IHI
+   30 CONTINUE
+      IF( I.LT.ILO )
+     $   GO TO 150
+*
+*     Perform QR iterations on rows and columns ILO to I until a
+*     submatrix of order 1 splits off at the bottom because a
+*     subdiagonal element has become negligible.
+*
+      L = ILO
+      DO 130 ITS = 0, ITMAX
+*
+*        Look for a single small subdiagonal element.
+*
+         DO 40 K = I, L + 1, -1
+            IF( CABS1( H( K, K-1 ) ).LE.SMLNUM )
+     $         GO TO 50
+            TST = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) )
+            IF( TST.EQ.ZERO ) THEN
+               IF( K-2.GE.ILO )
+     $            TST = TST + ABS( DBLE( H( K-1, K-2 ) ) )
+               IF( K+1.LE.IHI )
+     $            TST = TST + ABS( DBLE( H( K+1, K ) ) )
+            END IF
+*           ==== The following is a conservative small subdiagonal
+*           .    deflation criterion due to Ahues & Tisseur (LAWN 122,
+*           .    1997). It has better mathematical foundation and
+*           .    improves accuracy in some examples.  ====
+            IF( ABS( DBLE( H( K, K-1 ) ) ).LE.ULP*TST ) THEN
+               AB = MAX( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
+               BA = MIN( CABS1( H( K, K-1 ) ), CABS1( H( K-1, K ) ) )
+               AA = MAX( CABS1( H( K, K ) ),
+     $              CABS1( H( K-1, K-1 )-H( K, K ) ) )
+               BB = MIN( CABS1( H( K, K ) ),
+     $              CABS1( H( K-1, K-1 )-H( K, K ) ) )
+               S = AA + AB
+               IF( BA*( AB / S ).LE.MAX( SMLNUM,
+     $             ULP*( BB*( AA / S ) ) ) )GO TO 50
+            END IF
+   40    CONTINUE
+   50    CONTINUE
+         L = K
+         IF( L.GT.ILO ) THEN
+*
+*           H(L,L-1) is negligible
+*
+            H( L, L-1 ) = ZERO
+         END IF
+*
+*        Exit from loop if a submatrix of order 1 has split off.
+*
+         IF( L.GE.I )
+     $      GO TO 140
+*
+*        Now the active submatrix is in rows and columns L to I. If
+*        eigenvalues only are being computed, only the active submatrix
+*        need be transformed.
+*
+         IF( .NOT.WANTT ) THEN
+            I1 = L
+            I2 = I
+         END IF
+*
+         IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
+*
+*           Exceptional shift.
+*
+            S = DAT1*ABS( DBLE( H( I, I-1 ) ) )
+            T = S + H( I, I )
+         ELSE
+*
+*           Wilkinson's shift.
+*
+            T = H( I, I )
+            U = SQRT( H( I-1, I ) )*SQRT( H( I, I-1 ) )
+            S = CABS1( U )
+            IF( S.NE.RZERO ) THEN
+               X = HALF*( H( I-1, I-1 )-T )
+               SX = CABS1( X )
+               S = MAX( S, CABS1( X ) )
+               Y = S*SQRT( ( X / S )**2+( U / S )**2 )
+               IF( SX.GT.RZERO ) THEN
+                  IF( DBLE( X / SX )*DBLE( Y )+DIMAG( X / SX )*
+     $                DIMAG( Y ).LT.RZERO )Y = -Y
+               END IF
+               T = T - U*ZLADIV( U, ( X+Y ) )
+            END IF
+         END IF
+*
+*        Look for two consecutive small subdiagonal elements.
+*
+         DO 60 M = I - 1, L + 1, -1
+*
+*           Determine the effect of starting the single-shift QR
+*           iteration at row M, and see if this would make H(M,M-1)
+*           negligible.
+*
+            H11 = H( M, M )
+            H22 = H( M+1, M+1 )
+            H11S = H11 - T
+            H21 = H( M+1, M )
+            S = CABS1( H11S ) + ABS( H21 )
+            H11S = H11S / S
+            H21 = H21 / S
+            V( 1 ) = H11S
+            V( 2 ) = H21
+            H10 = H( M, M-1 )
+            IF( ABS( H10 )*ABS( H21 ).LE.ULP*
+     $          ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) )
+     $          GO TO 70
+   60    CONTINUE
+         H11 = H( L, L )
+         H22 = H( L+1, L+1 )
+         H11S = H11 - T
+         H21 = H( L+1, L )
+         S = CABS1( H11S ) + ABS( H21 )
+         H11S = H11S / S
+         H21 = H21 / S
+         V( 1 ) = H11S
+         V( 2 ) = H21
+   70    CONTINUE
+*
+*        Single-shift QR step
+*
+         DO 120 K = M, I - 1
+*
+*           The first iteration of this loop determines a reflection G
+*           from the vector V and applies it from left and right to H,
+*           thus creating a nonzero bulge below the subdiagonal.
+*
+*           Each subsequent iteration determines a reflection G to
+*           restore the Hessenberg form in the (K-1)th column, and thus
+*           chases the bulge one step toward the bottom of the active
+*           submatrix.
+*
+*           V(2) is always real before the call to ZLARFG, and hence
+*           after the call T2 ( = T1*V(2) ) is also real.
+*
+            IF( K.GT.M )
+     $         CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 )
+            CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 )
+            IF( K.GT.M ) THEN
+               H( K, K-1 ) = V( 1 )
+               H( K+1, K-1 ) = ZERO
+            END IF
+            V2 = V( 2 )
+            T2 = DBLE( T1*V2 )
+*
+*           Apply G from the left to transform the rows of the matrix
+*           in columns K to I2.
+*
+            DO 80 J = K, I2
+               SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J )
+               H( K, J ) = H( K, J ) - SUM
+               H( K+1, J ) = H( K+1, J ) - SUM*V2
+   80       CONTINUE
+*
+*           Apply G from the right to transform the columns of the
+*           matrix in rows I1 to min(K+2,I).
+*
+            DO 90 J = I1, MIN( K+2, I )
+               SUM = T1*H( J, K ) + T2*H( J, K+1 )
+               H( J, K ) = H( J, K ) - SUM
+               H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 )
+   90       CONTINUE
+*
+            IF( WANTZ ) THEN
+*
+*              Accumulate transformations in the matrix Z
+*
+               DO 100 J = ILOZ, IHIZ
+                  SUM = T1*Z( J, K ) + T2*Z( J, K+1 )
+                  Z( J, K ) = Z( J, K ) - SUM
+                  Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 )
+  100          CONTINUE
+            END IF
+*
+            IF( K.EQ.M .AND. M.GT.L ) THEN
+*
+*              If the QR step was started at row M > L because two
+*              consecutive small subdiagonals were found, then extra
+*              scaling must be performed to ensure that H(M,M-1) remains
+*              real.
+*
+               TEMP = ONE - T1
+               TEMP = TEMP / ABS( TEMP )
+               H( M+1, M ) = H( M+1, M )*DCONJG( TEMP )
+               IF( M+2.LE.I )
+     $            H( M+2, M+1 ) = H( M+2, M+1 )*TEMP
+               DO 110 J = M, I
+                  IF( J.NE.M+1 ) THEN
+                     IF( I2.GT.J )
+     $                  CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH )
+                     CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 )
+                     IF( WANTZ ) THEN
+                        CALL ZSCAL( NZ, DCONJG( TEMP ), Z( ILOZ, J ),
+     $                              1 )
+                     END IF
+                  END IF
+  110          CONTINUE
+            END IF
+  120    CONTINUE
+*
+*        Ensure that H(I,I-1) is real.
+*
+         TEMP = H( I, I-1 )
+         IF( DIMAG( TEMP ).NE.RZERO ) THEN
+            RTEMP = ABS( TEMP )
+            H( I, I-1 ) = RTEMP
+            TEMP = TEMP / RTEMP
+            IF( I2.GT.I )
+     $         CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH )
+            CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 )
+            IF( WANTZ ) THEN
+               CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 )
+            END IF
+         END IF
+*
+  130 CONTINUE
+*
+*     Failure to converge in remaining number of iterations
+*
+      INFO = I
+      RETURN
+*
+  140 CONTINUE
+*
+*     H(I,I-1) is negligible: one eigenvalue has converged.
+*
+      W( I ) = H( I, I )
+*
+*     return to start of the main loop with new value of I.
+*
+      I = L - 1
+      GO TO 30
+*
+  150 CONTINUE
+      RETURN
+*
+*     End of ZLAHQR
+*
+      END
diff --git a/src/lib/lapack/zlahr2.f b/src/lib/lapack/zlahr2.f
new file mode 100644
index 00000000..f3cb5515
--- /dev/null
+++ b/src/lib/lapack/zlahr2.f
@@ -0,0 +1,240 @@
+      SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            K, LDA, LDT, LDY, N, NB
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16        A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
+*  matrix A so that elements below the k-th subdiagonal are zero. The
+*  reduction is performed by an unitary similarity transformation
+*  Q' * A * Q. The routine returns the matrices V and T which determine
+*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+*  This is an auxiliary routine called by ZGEHRD.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  K       (input) INTEGER
+*          The offset for the reduction. Elements below the k-th
+*          subdiagonal in the first NB columns are reduced to zero.
+*          K < N.
+*
+*  NB      (input) INTEGER
+*          The number of columns to be reduced.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)
+*          On entry, the n-by-(n-k+1) general matrix A.
+*          On exit, the elements on and above the k-th subdiagonal in
+*          the first NB columns are overwritten with the corresponding
+*          elements of the reduced matrix; the elements below the k-th
+*          subdiagonal, with the array TAU, represent the matrix Q as a
+*          product of elementary reflectors. The other columns of A are
+*          unchanged. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) COMPLEX*16 array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)
+*          The n-by-nb matrix Y.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= N.
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of nb elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+*  A(i+k+1:n,i), and tau in TAU(i).
+*
+*  The elements of the vectors v together form the (n-k+1)-by-nb matrix
+*  V which is needed, with T and Y, to apply the transformation to the
+*  unreduced part of the matrix, using an update of the form:
+*  A := (I - V*T*V') * (A - Y*V').
+*
+*  The contents of A on exit are illustrated by the following example
+*  with n = 7, k = 3 and nb = 2:
+*
+*     ( a   a   a   a   a )
+*     ( a   a   a   a   a )
+*     ( a   a   a   a   a )
+*     ( h   h   a   a   a )
+*     ( v1  h   a   a   a )
+*     ( v1  v2  a   a   a )
+*     ( v1  v2  a   a   a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  This file is a slight modification of LAPACK-3.0's ZLAHRD
+*  incorporating improvements proposed by Quintana-Orti and Van de
+*  Gejin. Note that the entries of A(1:K,2:NB) differ from those
+*  returned by the original LAPACK routine. This function is
+*  not backward compatible with LAPACK3.0.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16        ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ), 
+     $                     ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16        EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZCOPY, ZGEMM, ZGEMV, ZLACPY,
+     $                   ZLARFG, ZSCAL, ZTRMM, ZTRMV, ZLACGV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      DO 10 I = 1, NB
+         IF( I.GT.1 ) THEN
+*
+*           Update A(K+1:N,I)
+*
+*           Update I-th column of A - Y * V'
+*
+            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) 
+            CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
+     $                  A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
+            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA ) 
+*
+*           Apply I - V * T' * V' to this column (call it b) from the
+*           left, using the last column of T as workspace
+*
+*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
+*                    ( V2 )             ( b2 )
+*
+*           where V1 is unit lower triangular
+*
+*           w := V1' * b1
+*
+            CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL ZTRMV( 'Lower', 'Conjugate transpose', 'UNIT', 
+     $                  I-1, A( K+1, 1 ),
+     $                  LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, 
+     $                  ONE, A( K+I, 1 ),
+     $                  LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+*           w := T'*w
+*
+            CALL ZTRMV( 'Upper', 'Conjugate transpose', 'NON-UNIT', 
+     $                  I-1, T, LDT,
+     $                  T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL ZGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE, 
+     $                  A( K+I, 1 ),
+     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+*           b1 := b1 - V1*w
+*
+            CALL ZTRMV( 'Lower', 'NO TRANSPOSE', 
+     $                  'UNIT', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+            A( K+I-1, I-1 ) = EI
+         END IF
+*
+*        Generate the elementary reflector H(I) to annihilate
+*        A(K+I+1:N,I)
+*
+         CALL ZLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+     $                TAU( I ) )
+         EI = A( K+I, I )
+         A( K+I, I ) = ONE
+*
+*        Compute  Y(K+1:N,I)
+*
+         CALL ZGEMV( 'NO TRANSPOSE', N-K, N-K-I+1, 
+     $               ONE, A( K+1, I+1 ),
+     $               LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
+         CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, 
+     $               ONE, A( K+I, 1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+         CALL ZGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, 
+     $               Y( K+1, 1 ), LDY,
+     $               T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+         CALL ZSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+*        Compute T(1:I,I)
+*
+         CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL ZTRMV( 'Upper', 'No Transpose', 'NON-UNIT', 
+     $               I-1, T, LDT,
+     $               T( 1, I ), 1 )
+         T( I, I ) = TAU( I )
+*
+   10 CONTINUE
+      A( K+NB, NB ) = EI
+*
+*     Compute Y(1:K,1:NB)
+*
+      CALL ZLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+      CALL ZTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE', 
+     $            'UNIT', K, NB,
+     $            ONE, A( K+1, 1 ), LDA, Y, LDY )
+      IF( N.GT.K+NB )
+     $   CALL ZGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K, 
+     $               NB, N-K-NB, ONE,
+     $               A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
+     $               LDY )
+      CALL ZTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE', 
+     $            'NON-UNIT', K, NB,
+     $            ONE, T, LDT, Y, LDY )
+*
+      RETURN
+*
+*     End of ZLAHR2
+*
+      END
diff --git a/src/lib/lapack/zlahrd.f b/src/lib/lapack/zlahrd.f
new file mode 100644
index 00000000..e7eb9de9
--- /dev/null
+++ b/src/lib/lapack/zlahrd.f
@@ -0,0 +1,213 @@
+      SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            K, LDA, LDT, LDY, N, NB
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), T( LDT, NB ), TAU( NB ),
+     $                   Y( LDY, NB )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
+*  matrix A so that elements below the k-th subdiagonal are zero. The
+*  reduction is performed by a unitary similarity transformation
+*  Q' * A * Q. The routine returns the matrices V and T which determine
+*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+*  This is an OBSOLETE auxiliary routine. 
+*  This routine will be 'deprecated' in a  future release.
+*  Please use the new routine ZLAHR2 instead.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  K       (input) INTEGER
+*          The offset for the reduction. Elements below the k-th
+*          subdiagonal in the first NB columns are reduced to zero.
+*
+*  NB      (input) INTEGER
+*          The number of columns to be reduced.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)
+*          On entry, the n-by-(n-k+1) general matrix A.
+*          On exit, the elements on and above the k-th subdiagonal in
+*          the first NB columns are overwritten with the corresponding
+*          elements of the reduced matrix; the elements below the k-th
+*          subdiagonal, with the array TAU, represent the matrix Q as a
+*          product of elementary reflectors. The other columns of A are
+*          unchanged. See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (NB)
+*          The scalar factors of the elementary reflectors. See Further
+*          Details.
+*
+*  T       (output) COMPLEX*16 array, dimension (LDT,NB)
+*          The upper triangular matrix T.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T.  LDT >= NB.
+*
+*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)
+*          The n-by-nb matrix Y.
+*
+*  LDY     (input) INTEGER
+*          The leading dimension of the array Y. LDY >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  The matrix Q is represented as a product of nb elementary reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+*  A(i+k+1:n,i), and tau in TAU(i).
+*
+*  The elements of the vectors v together form the (n-k+1)-by-nb matrix
+*  V which is needed, with T and Y, to apply the transformation to the
+*  unreduced part of the matrix, using an update of the form:
+*  A := (I - V*T*V') * (A - Y*V').
+*
+*  The contents of A on exit are illustrated by the following example
+*  with n = 7, k = 3 and nb = 2:
+*
+*     ( a   h   a   a   a )
+*     ( a   h   a   a   a )
+*     ( a   h   a   a   a )
+*     ( h   h   a   a   a )
+*     ( v1  h   a   a   a )
+*     ( v1  v2  a   a   a )
+*     ( v1  v2  a   a   a )
+*
+*  where a denotes an element of the original matrix A, h denotes a
+*  modified element of the upper Hessenberg matrix H, and vi denotes an
+*  element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         EI
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZCOPY, ZGEMV, ZLACGV, ZLARFG, ZSCAL,
+     $                   ZTRMV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      DO 10 I = 1, NB
+         IF( I.GT.1 ) THEN
+*
+*           Update A(1:n,i)
+*
+*           Compute i-th column of A - Y * V'
+*
+            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
+            CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
+     $                  A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
+            CALL ZLACGV( I-1, A( K+I-1, 1 ), LDA )
+*
+*           Apply I - V * T' * V' to this column (call it b) from the
+*           left, using the last column of T as workspace
+*
+*           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
+*                    ( V2 )             ( b2 )
+*
+*           where V1 is unit lower triangular
+*
+*           w := V1' * b1
+*
+            CALL ZCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+            CALL ZTRMV( 'Lower', 'Conjugate transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+*
+*           w := w + V2'*b2
+*
+            CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
+     $                  A( K+I, 1 ), LDA, A( K+I, I ), 1, ONE,
+     $                  T( 1, NB ), 1 )
+*
+*           w := T'*w
+*
+            CALL ZTRMV( 'Upper', 'Conjugate transpose', 'Non-unit', I-1,
+     $                  T, LDT, T( 1, NB ), 1 )
+*
+*           b2 := b2 - V2*w
+*
+            CALL ZGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
+     $                  LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+*           b1 := b1 - V1*w
+*
+            CALL ZTRMV( 'Lower', 'No transpose', 'Unit', I-1,
+     $                  A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+            CALL ZAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+            A( K+I-1, I-1 ) = EI
+         END IF
+*
+*        Generate the elementary reflector H(i) to annihilate
+*        A(k+i+1:n,i)
+*
+         EI = A( K+I, I )
+         CALL ZLARFG( N-K-I+1, EI, A( MIN( K+I+1, N ), I ), 1,
+     $                TAU( I ) )
+         A( K+I, I ) = ONE
+*
+*        Compute  Y(1:n,i)
+*
+         CALL ZGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+     $               A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+         CALL ZGEMV( 'Conjugate transpose', N-K-I+1, I-1, ONE,
+     $               A( K+I, 1 ), LDA, A( K+I, I ), 1, ZERO, T( 1, I ),
+     $               1 )
+         CALL ZGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+     $               ONE, Y( 1, I ), 1 )
+         CALL ZSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+*        Compute T(1:i,i)
+*
+         CALL ZSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+         CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
+     $               T( 1, I ), 1 )
+         T( I, I ) = TAU( I )
+*
+   10 CONTINUE
+      A( K+NB, NB ) = EI
+*
+      RETURN
+*
+*     End of ZLAHRD
+*
+      END
diff --git a/src/lib/lapack/zlaic1.f b/src/lib/lapack/zlaic1.f
new file mode 100644
index 00000000..589f0889
--- /dev/null
+++ b/src/lib/lapack/zlaic1.f
@@ -0,0 +1,295 @@
+      SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            J, JOB
+      DOUBLE PRECISION   SEST, SESTPR
+      COMPLEX*16         C, GAMMA, S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         W( J ), X( J )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAIC1 applies one step of incremental condition estimation in
+*  its simplest version:
+*
+*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
+*  lower triangular matrix L, such that
+*           twonorm(L*x) = sest
+*  Then ZLAIC1 computes sestpr, s, c such that
+*  the vector
+*                  [ s*x ]
+*           xhat = [  c  ]
+*  is an approximate singular vector of
+*                  [ L     0  ]
+*           Lhat = [ w' gamma ]
+*  in the sense that
+*           twonorm(Lhat*xhat) = sestpr.
+*
+*  Depending on JOB, an estimate for the largest or smallest singular
+*  value is computed.
+*
+*  Note that [s c]' and sestpr**2 is an eigenpair of the system
+*
+*      diag(sest*sest, 0) + [alpha  gamma] * [ conjg(alpha) ]
+*                                            [ conjg(gamma) ]
+*
+*  where  alpha =  conjg(x)'*w.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) INTEGER
+*          = 1: an estimate for the largest singular value is computed.
+*          = 2: an estimate for the smallest singular value is computed.
+*
+*  J       (input) INTEGER
+*          Length of X and W
+*
+*  X       (input) COMPLEX*16 array, dimension (J)
+*          The j-vector x.
+*
+*  SEST    (input) DOUBLE PRECISION
+*          Estimated singular value of j by j matrix L
+*
+*  W       (input) COMPLEX*16 array, dimension (J)
+*          The j-vector w.
+*
+*  GAMMA   (input) COMPLEX*16
+*          The diagonal element gamma.
+*
+*  SESTPR  (output) DOUBLE PRECISION
+*          Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+*  S       (output) COMPLEX*16
+*          Sine needed in forming xhat.
+*
+*  C       (output) COMPLEX*16
+*          Cosine needed in forming xhat.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+      DOUBLE PRECISION   HALF, FOUR
+      PARAMETER          ( HALF = 0.5D0, FOUR = 4.0D0 )
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION   ABSALP, ABSEST, ABSGAM, B, EPS, NORMA, S1, S2,
+     $                   SCL, T, TEST, TMP, ZETA1, ZETA2
+      COMPLEX*16         ALPHA, COSINE, SINE
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCONJG, MAX, SQRT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      COMPLEX*16         ZDOTC
+      EXTERNAL           DLAMCH, ZDOTC
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'Epsilon' )
+      ALPHA = ZDOTC( J, X, 1, W, 1 )
+*
+      ABSALP = ABS( ALPHA )
+      ABSGAM = ABS( GAMMA )
+      ABSEST = ABS( SEST )
+*
+      IF( JOB.EQ.1 ) THEN
+*
+*        Estimating largest singular value
+*
+*        special cases
+*
+         IF( SEST.EQ.ZERO ) THEN
+            S1 = MAX( ABSGAM, ABSALP )
+            IF( S1.EQ.ZERO ) THEN
+               S = ZERO
+               C = ONE
+               SESTPR = ZERO
+            ELSE
+               S = ALPHA / S1
+               C = GAMMA / S1
+               TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) )
+               S = S / TMP
+               C = C / TMP
+               SESTPR = S1*TMP
+            END IF
+            RETURN
+         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+            S = ONE
+            C = ZERO
+            TMP = MAX( ABSEST, ABSALP )
+            S1 = ABSEST / TMP
+            S2 = ABSALP / TMP
+            SESTPR = TMP*SQRT( S1*S1+S2*S2 )
+            RETURN
+         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+            S1 = ABSGAM
+            S2 = ABSEST
+            IF( S1.LE.S2 ) THEN
+               S = ONE
+               C = ZERO
+               SESTPR = S2
+            ELSE
+               S = ZERO
+               C = ONE
+               SESTPR = S1
+            END IF
+            RETURN
+         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+            S1 = ABSGAM
+            S2 = ABSALP
+            IF( S1.LE.S2 ) THEN
+               TMP = S1 / S2
+               SCL = SQRT( ONE+TMP*TMP )
+               SESTPR = S2*SCL
+               S = ( ALPHA / S2 ) / SCL
+               C = ( GAMMA / S2 ) / SCL
+            ELSE
+               TMP = S2 / S1
+               SCL = SQRT( ONE+TMP*TMP )
+               SESTPR = S1*SCL
+               S = ( ALPHA / S1 ) / SCL
+               C = ( GAMMA / S1 ) / SCL
+            END IF
+            RETURN
+         ELSE
+*
+*           normal case
+*
+            ZETA1 = ABSALP / ABSEST
+            ZETA2 = ABSGAM / ABSEST
+*
+            B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
+            C = ZETA1*ZETA1
+            IF( B.GT.ZERO ) THEN
+               T = C / ( B+SQRT( B*B+C ) )
+            ELSE
+               T = SQRT( B*B+C ) - B
+            END IF
+*
+            SINE = -( ALPHA / ABSEST ) / T
+            COSINE = -( GAMMA / ABSEST ) / ( ONE+T )
+            TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) )
+            S = SINE / TMP
+            C = COSINE / TMP
+            SESTPR = SQRT( T+ONE )*ABSEST
+            RETURN
+         END IF
+*
+      ELSE IF( JOB.EQ.2 ) THEN
+*
+*        Estimating smallest singular value
+*
+*        special cases
+*
+         IF( SEST.EQ.ZERO ) THEN
+            SESTPR = ZERO
+            IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
+               SINE = ONE
+               COSINE = ZERO
+            ELSE
+               SINE = -DCONJG( GAMMA )
+               COSINE = DCONJG( ALPHA )
+            END IF
+            S1 = MAX( ABS( SINE ), ABS( COSINE ) )
+            S = SINE / S1
+            C = COSINE / S1
+            TMP = SQRT( S*DCONJG( S )+C*DCONJG( C ) )
+            S = S / TMP
+            C = C / TMP
+            RETURN
+         ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+            S = ZERO
+            C = ONE
+            SESTPR = ABSGAM
+            RETURN
+         ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+            S1 = ABSGAM
+            S2 = ABSEST
+            IF( S1.LE.S2 ) THEN
+               S = ZERO
+               C = ONE
+               SESTPR = S1
+            ELSE
+               S = ONE
+               C = ZERO
+               SESTPR = S2
+            END IF
+            RETURN
+         ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+            S1 = ABSGAM
+            S2 = ABSALP
+            IF( S1.LE.S2 ) THEN
+               TMP = S1 / S2
+               SCL = SQRT( ONE+TMP*TMP )
+               SESTPR = ABSEST*( TMP / SCL )
+               S = -( DCONJG( GAMMA ) / S2 ) / SCL
+               C = ( DCONJG( ALPHA ) / S2 ) / SCL
+            ELSE
+               TMP = S2 / S1
+               SCL = SQRT( ONE+TMP*TMP )
+               SESTPR = ABSEST / SCL
+               S = -( DCONJG( GAMMA ) / S1 ) / SCL
+               C = ( DCONJG( ALPHA ) / S1 ) / SCL
+            END IF
+            RETURN
+         ELSE
+*
+*           normal case
+*
+            ZETA1 = ABSALP / ABSEST
+            ZETA2 = ABSGAM / ABSEST
+*
+            NORMA = MAX( ONE+ZETA1*ZETA1+ZETA1*ZETA2,
+     $              ZETA1*ZETA2+ZETA2*ZETA2 )
+*
+*           See if root is closer to zero or to ONE
+*
+            TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
+            IF( TEST.GE.ZERO ) THEN
+*
+*              root is close to zero, compute directly
+*
+               B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
+               C = ZETA2*ZETA2
+               T = C / ( B+SQRT( ABS( B*B-C ) ) )
+               SINE = ( ALPHA / ABSEST ) / ( ONE-T )
+               COSINE = -( GAMMA / ABSEST ) / T
+               SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
+            ELSE
+*
+*              root is closer to ONE, shift by that amount
+*
+               B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
+               C = ZETA1*ZETA1
+               IF( B.GE.ZERO ) THEN
+                  T = -C / ( B+SQRT( B*B+C ) )
+               ELSE
+                  T = B - SQRT( B*B+C )
+               END IF
+               SINE = -( ALPHA / ABSEST ) / T
+               COSINE = -( GAMMA / ABSEST ) / ( ONE+T )
+               SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
+            END IF
+            TMP = SQRT( SINE*DCONJG( SINE )+COSINE*DCONJG( COSINE ) )
+            S = SINE / TMP
+            C = COSINE / TMP
+            RETURN
+*
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLAIC1
+*
+      END
diff --git a/src/lib/lapack/zlange.f b/src/lib/lapack/zlange.f
new file mode 100644
index 00000000..36cecbdc
--- /dev/null
+++ b/src/lib/lapack/zlange.f
@@ -0,0 +1,145 @@
+      DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANGE  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  complex matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANGE returns the value
+*
+*     ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in ZLANGE as described
+*          above.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.  When M = 0,
+*          ZLANGE is set to zero.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.  When N = 0,
+*          ZLANGE is set to zero.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The m by n matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(M,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( MIN( M, N ).EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         DO 20 J = 1, N
+            DO 10 I = 1, M
+               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         DO 40 J = 1, N
+            SUM = ZERO
+            DO 30 I = 1, M
+               SUM = SUM + ABS( A( I, J ) )
+   30       CONTINUE
+            VALUE = MAX( VALUE, SUM )
+   40    CONTINUE
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         DO 50 I = 1, M
+            WORK( I ) = ZERO
+   50    CONTINUE
+         DO 70 J = 1, N
+            DO 60 I = 1, M
+               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, M
+            VALUE = MAX( VALUE, WORK( I ) )
+   80    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         DO 90 J = 1, N
+            CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANGE = VALUE
+      RETURN
+*
+*     End of ZLANGE
+*
+      END
diff --git a/src/lib/lapack/zlanhe.f b/src/lib/lapack/zlanhe.f
new file mode 100644
index 00000000..86e57fcd
--- /dev/null
+++ b/src/lib/lapack/zlanhe.f
@@ -0,0 +1,187 @@
+      DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM, UPLO
+      INTEGER            LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANHE  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  complex hermitian matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANHE returns the value
+*
+*     ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in ZLANHE as described
+*          above.
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          hermitian matrix A is to be referenced.
+*          = 'U':  Upper triangular part of A is referenced
+*          = 'L':  Lower triangular part of A is referenced
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHE is
+*          set to zero.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The hermitian matrix A.  If UPLO = 'U', the leading n by n
+*          upper triangular part of A contains the upper triangular part
+*          of the matrix A, and the strictly lower triangular part of A
+*          is not referenced.  If UPLO = 'L', the leading n by n lower
+*          triangular part of A contains the lower triangular part of
+*          the matrix A, and the strictly upper triangular part of A is
+*          not referenced. Note that the imaginary parts of the diagonal
+*          elements need not be set and are assumed to be zero.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+*          WORK is not referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 20 J = 1, N
+               DO 10 I = 1, J - 1
+                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10          CONTINUE
+               VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) )
+   20       CONTINUE
+         ELSE
+            DO 40 J = 1, N
+               VALUE = MAX( VALUE, ABS( DBLE( A( J, J ) ) ) )
+               DO 30 I = J + 1, N
+                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   30          CONTINUE
+   40       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+     $         ( NORM.EQ.'1' ) ) THEN
+*
+*        Find normI(A) ( = norm1(A), since A is hermitian).
+*
+         VALUE = ZERO
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 60 J = 1, N
+               SUM = ZERO
+               DO 50 I = 1, J - 1
+                  ABSA = ABS( A( I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   50          CONTINUE
+               WORK( J ) = SUM + ABS( DBLE( A( J, J ) ) )
+   60       CONTINUE
+            DO 70 I = 1, N
+               VALUE = MAX( VALUE, WORK( I ) )
+   70       CONTINUE
+         ELSE
+            DO 80 I = 1, N
+               WORK( I ) = ZERO
+   80       CONTINUE
+            DO 100 J = 1, N
+               SUM = WORK( J ) + ABS( DBLE( A( J, J ) ) )
+               DO 90 I = J + 1, N
+                  ABSA = ABS( A( I, J ) )
+                  SUM = SUM + ABSA
+                  WORK( I ) = WORK( I ) + ABSA
+   90          CONTINUE
+               VALUE = MAX( VALUE, SUM )
+  100       CONTINUE
+         END IF
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         IF( LSAME( UPLO, 'U' ) ) THEN
+            DO 110 J = 2, N
+               CALL ZLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+  110       CONTINUE
+         ELSE
+            DO 120 J = 1, N - 1
+               CALL ZLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+  120       CONTINUE
+         END IF
+         SUM = 2*SUM
+         DO 130 I = 1, N
+            IF( DBLE( A( I, I ) ).NE.ZERO ) THEN
+               ABSA = ABS( DBLE( A( I, I ) ) )
+               IF( SCALE.LT.ABSA ) THEN
+                  SUM = ONE + SUM*( SCALE / ABSA )**2
+                  SCALE = ABSA
+               ELSE
+                  SUM = SUM + ( ABSA / SCALE )**2
+               END IF
+            END IF
+  130    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANHE = VALUE
+      RETURN
+*
+*     End of ZLANHE
+*
+      END
diff --git a/src/lib/lapack/zlanhs.f b/src/lib/lapack/zlanhs.f
new file mode 100644
index 00000000..d7b187a5
--- /dev/null
+++ b/src/lib/lapack/zlanhs.f
@@ -0,0 +1,142 @@
+      DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          NORM
+      INTEGER            LDA, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   WORK( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLANHS  returns the value of the one norm,  or the Frobenius norm, or
+*  the  infinity norm,  or the  element of  largest absolute value  of a
+*  Hessenberg matrix A.
+*
+*  Description
+*  ===========
+*
+*  ZLANHS returns the value
+*
+*     ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+*              (
+*              ( norm1(A),         NORM = '1', 'O' or 'o'
+*              (
+*              ( normI(A),         NORM = 'I' or 'i'
+*              (
+*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
+*
+*  where  norm1  denotes the  one norm of a matrix (maximum column sum),
+*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
+*  normF  denotes the  Frobenius norm of a matrix (square root of sum of
+*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
+*
+*  Arguments
+*  =========
+*
+*  NORM    (input) CHARACTER*1
+*          Specifies the value to be returned in ZLANHS as described
+*          above.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHS is
+*          set to zero.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The n by n upper Hessenberg matrix A; the part of A below the
+*          first sub-diagonal is not referenced.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(N,1).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+*          referenced.
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      DOUBLE PRECISION   SCALE, SUM, VALUE
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLASSQ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.EQ.0 ) THEN
+         VALUE = ZERO
+      ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+*        Find max(abs(A(i,j))).
+*
+         VALUE = ZERO
+         DO 20 J = 1, N
+            DO 10 I = 1, MIN( N, J+1 )
+               VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+   10       CONTINUE
+   20    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+*        Find norm1(A).
+*
+         VALUE = ZERO
+         DO 40 J = 1, N
+            SUM = ZERO
+            DO 30 I = 1, MIN( N, J+1 )
+               SUM = SUM + ABS( A( I, J ) )
+   30       CONTINUE
+            VALUE = MAX( VALUE, SUM )
+   40    CONTINUE
+      ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+*        Find normI(A).
+*
+         DO 50 I = 1, N
+            WORK( I ) = ZERO
+   50    CONTINUE
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( N, J+1 )
+               WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+   60       CONTINUE
+   70    CONTINUE
+         VALUE = ZERO
+         DO 80 I = 1, N
+            VALUE = MAX( VALUE, WORK( I ) )
+   80    CONTINUE
+      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+*        Find normF(A).
+*
+         SCALE = ZERO
+         SUM = ONE
+         DO 90 J = 1, N
+            CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+   90    CONTINUE
+         VALUE = SCALE*SQRT( SUM )
+      END IF
+*
+      ZLANHS = VALUE
+      RETURN
+*
+*     End of ZLANHS
+*
+      END
diff --git a/src/lib/lapack/zlaqp2.f b/src/lib/lapack/zlaqp2.f
new file mode 100644
index 00000000..46f6d95c
--- /dev/null
+++ b/src/lib/lapack/zlaqp2.f
@@ -0,0 +1,179 @@
+      SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
+     $                   WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            LDA, M, N, OFFSET
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   VN1( * ), VN2( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQP2 computes a QR factorization with column pivoting of
+*  the block A(OFFSET+1:M,1:N).
+*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0.
+*
+*  OFFSET  (input) INTEGER
+*          The number of rows of the matrix A that must be pivoted
+*          but no factorized. OFFSET >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
+*          the triangular factor obtained; the elements in block
+*          A(OFFSET+1:M,1:N) below the diagonal, together with the
+*          array TAU, represent the orthogonal matrix Q as a product of
+*          elementary reflectors. Block A(1:OFFSET,1:N) has been
+*          accordingly pivoted, but no factorized.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+*          to the front of A*P (a leading column); if JPVT(i) = 0,
+*          the i-th column of A is a free column.
+*          On exit, if JPVT(i) = k, then the i-th column of A*P
+*          was the k-th column of A.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  Partial column norm updating strategy modified by
+*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+*    University of Zagreb, Croatia.
+*    June 2006.
+*  For more details see LAPACK Working Note 176.
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      COMPLEX*16         CONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ITEMP, J, MN, OFFPI, PVT
+      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
+      COMPLEX*16         AII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLARF, ZLARFG, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCONJG, MAX, MIN, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      MN = MIN( M-OFFSET, N )
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Compute factorization.
+*
+      DO 20 I = 1, MN
+*
+         OFFPI = OFFSET + I
+*
+*        Determine ith pivot column and swap if necessary.
+*
+         PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
+*
+         IF( PVT.NE.I ) THEN
+            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+            ITEMP = JPVT( PVT )
+            JPVT( PVT ) = JPVT( I )
+            JPVT( I ) = ITEMP
+            VN1( PVT ) = VN1( I )
+            VN2( PVT ) = VN2( I )
+         END IF
+*
+*        Generate elementary reflector H(i).
+*
+         IF( OFFPI.LT.M ) THEN
+            CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+     $                   TAU( I ) )
+         ELSE
+            CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
+         END IF
+*
+         IF( I.LT.N ) THEN
+*
+*           Apply H(i)' to A(offset+i:m,i+1:n) from the left.
+*
+            AII = A( OFFPI, I )
+            A( OFFPI, I ) = CONE
+            CALL ZLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+     $                  DCONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA,
+     $                  WORK( 1 ) )
+            A( OFFPI, I ) = AII
+         END IF
+*
+*        Update partial column norms.
+*
+         DO 10 J = I + 1, N
+            IF( VN1( J ).NE.ZERO ) THEN
+*
+*              NOTE: The following 4 lines follow from the analysis in
+*              Lapack Working Note 176.
+*
+               TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
+               TEMP = MAX( TEMP, ZERO )
+               TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+               IF( TEMP2 .LE. TOL3Z ) THEN
+                  IF( OFFPI.LT.M ) THEN
+                     VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
+                     VN2( J ) = VN1( J )
+                  ELSE
+                     VN1( J ) = ZERO
+                     VN2( J ) = ZERO
+                  END IF
+               ELSE
+                  VN1( J ) = VN1( J )*SQRT( TEMP )
+               END IF
+            END IF
+   10    CONTINUE
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of ZLAQP2
+*
+      END
diff --git a/src/lib/lapack/zlaqps.f b/src/lib/lapack/zlaqps.f
new file mode 100644
index 00000000..40414503
--- /dev/null
+++ b/src/lib/lapack/zlaqps.f
@@ -0,0 +1,266 @@
+      SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
+     $                   VN2, AUXV, F, LDF )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
+*     ..
+*     .. Array Arguments ..
+      INTEGER            JPVT( * )
+      DOUBLE PRECISION   VN1( * ), VN2( * )
+      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLAQPS computes a step of QR factorization with column pivoting
+*  of a complex M-by-N matrix A by using Blas-3.  It tries to factorize
+*  NB columns from A starting from the row OFFSET+1, and updates all
+*  of the matrix with Blas-3 xGEMM.
+*
+*  In some cases, due to catastrophic cancellations, it cannot
+*  factorize NB columns.  Hence, the actual number of factorized
+*  columns is returned in KB.
+*
+*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A. N >= 0
+*
+*  OFFSET  (input) INTEGER
+*          The number of rows of A that have been factorized in
+*          previous steps.
+*
+*  NB      (input) INTEGER
+*          The number of columns to factorize.
+*
+*  KB      (output) INTEGER
+*          The number of columns actually factorized.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the M-by-N matrix A.
+*          On exit, block A(OFFSET+1:M,1:KB) is the triangular
+*          factor obtained and block A(1:OFFSET,1:N) has been
+*          accordingly pivoted, but no factorized.
+*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
+*          been updated.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  JPVT    (input/output) INTEGER array, dimension (N)
+*          JPVT(I) = K <==> Column K of the full matrix A has been
+*          permuted into position I in AP.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (KB)
+*          The scalar factors of the elementary reflectors.
+*
+*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the partial column norms.
+*
+*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)
+*          The vector with the exact column norms.
+*
+*  AUXV    (input/output) COMPLEX*16 array, dimension (NB)
+*          Auxiliar vector.
+*
+*  F       (input/output) COMPLEX*16 array, dimension (LDF,NB)
+*          Matrix F' = L*Y'*A.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the array F. LDF >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*    X. Sun, Computer Science Dept., Duke University, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
+     $                   CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
+      COMPLEX*16         AKK
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMM, ZGEMV, ZLARFG, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, MAX, MIN, NINT, SQRT
+*     ..
+*     .. External Functions ..
+      INTEGER            IDAMAX
+      DOUBLE PRECISION   DLAMCH, DZNRM2
+      EXTERNAL           IDAMAX, DLAMCH, DZNRM2
+*     ..
+*     .. Executable Statements ..
+*
+      LASTRK = MIN( M, N+OFFSET )
+      LSTICC = 0
+      K = 0
+      TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+*     Beginning of while loop.
+*
+   10 CONTINUE
+      IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
+         K = K + 1
+         RK = OFFSET + K
+*
+*        Determine ith pivot column and swap if necessary
+*
+         PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
+         IF( PVT.NE.K ) THEN
+            CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+            CALL ZSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
+            ITEMP = JPVT( PVT )
+            JPVT( PVT ) = JPVT( K )
+            JPVT( K ) = ITEMP
+            VN1( PVT ) = VN1( K )
+            VN2( PVT ) = VN2( K )
+         END IF
+*
+*        Apply previous Householder reflectors to column K:
+*        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'.
+*
+         IF( K.GT.1 ) THEN
+            DO 20 J = 1, K - 1
+               F( K, J ) = DCONJG( F( K, J ) )
+   20       CONTINUE
+            CALL ZGEMV( 'No transpose', M-RK+1, K-1, -CONE, A( RK, 1 ),
+     $                  LDA, F( K, 1 ), LDF, CONE, A( RK, K ), 1 )
+            DO 30 J = 1, K - 1
+               F( K, J ) = DCONJG( F( K, J ) )
+   30       CONTINUE
+         END IF
+*
+*        Generate elementary reflector H(k).
+*
+         IF( RK.LT.M ) THEN
+            CALL ZLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+         ELSE
+            CALL ZLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
+         END IF
+*
+         AKK = A( RK, K )
+         A( RK, K ) = CONE
+*
+*        Compute Kth column of F:
+*
+*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K).
+*
+         IF( K.LT.N ) THEN
+            CALL ZGEMV( 'Conjugate transpose', M-RK+1, N-K, TAU( K ),
+     $                  A( RK, K+1 ), LDA, A( RK, K ), 1, CZERO,
+     $                  F( K+1, K ), 1 )
+         END IF
+*
+*        Padding F(1:K,K) with zeros.
+*
+         DO 40 J = 1, K
+            F( J, K ) = CZERO
+   40    CONTINUE
+*
+*        Incremental updating of F:
+*        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
+*                    *A(RK:M,K).
+*
+         IF( K.GT.1 ) THEN
+            CALL ZGEMV( 'Conjugate transpose', M-RK+1, K-1, -TAU( K ),
+     $                  A( RK, 1 ), LDA, A( RK, K ), 1, CZERO,
+     $                  AUXV( 1 ), 1 )
+*
+            CALL ZGEMV( 'No transpose', N, K-1, CONE, F( 1, 1 ), LDF,
+     $                  AUXV( 1 ), 1, CONE, F( 1, K ), 1 )
+         END IF
+*
+*        Update the current row of A:
+*        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'.
+*
+         IF( K.LT.N ) THEN
+            CALL ZGEMM( 'No transpose', 'Conjugate transpose', 1, N-K,
+     $                  K, -CONE, A( RK, 1 ), LDA, F( K+1, 1 ), LDF,
+     $                  CONE, A( RK, K+1 ), LDA )
+         END IF
+*
+*        Update partial column norms.
+*
+         IF( RK.LT.LASTRK ) THEN
+            DO 50 J = K + 1, N
+               IF( VN1( J ).NE.ZERO ) THEN
+*
+*                 NOTE: The following 4 lines follow from the analysis in
+*                 Lapack Working Note 176.
+*
+                  TEMP = ABS( A( RK, J ) ) / VN1( J )
+                  TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+                  TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+                  IF( TEMP2 .LE. TOL3Z ) THEN
+                     VN2( J ) = DBLE( LSTICC )
+                     LSTICC = J
+                  ELSE
+                     VN1( J ) = VN1( J )*SQRT( TEMP )
+                  END IF
+               END IF
+   50       CONTINUE
+         END IF
+*
+         A( RK, K ) = AKK
+*
+*        End of while loop.
+*
+         GO TO 10
+      END IF
+      KB = K
+      RK = OFFSET + KB
+*
+*     Apply the block reflector to the rest of the matrix:
+*     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
+*                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
+*
+      IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
+         CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-RK, N-KB,
+     $               KB, -CONE, A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF,
+     $               CONE, A( RK+1, KB+1 ), LDA )
+      END IF
+*
+*     Recomputation of difficult columns.
+*
+   60 CONTINUE
+      IF( LSTICC.GT.0 ) THEN
+         ITEMP = NINT( VN2( LSTICC ) )
+         VN1( LSTICC ) = DZNRM2( M-RK, A( RK+1, LSTICC ), 1 )
+*
+*        NOTE: The computation of VN1( LSTICC ) relies on the fact that 
+*        SNRM2 does not fail on vectors with norm below the value of
+*        SQRT(DLAMCH('S')) 
+*
+         VN2( LSTICC ) = VN1( LSTICC )
+         LSTICC = ITEMP
+         GO TO 60
+      END IF
+*
+      RETURN
+*
+*     End of ZLAQPS
+*
+      END
diff --git a/src/lib/lapack/zlaqr0.f b/src/lib/lapack/zlaqr0.f
new file mode 100644
index 00000000..2a35a725
--- /dev/null
+++ b/src/lib/lapack/zlaqr0.f
@@ -0,0 +1,601 @@
+      SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*     Purpose
+*     =======
+*
+*     ZLAQR0 computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**H, where T is an upper triangular matrix (the
+*     Schur form), and Z is the unitary matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input unitary
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*           previous call to ZGEBAL, and then passed to ZGEHRD when the
+*           matrix output by ZGEBAL is reduced to Hessenberg form.
+*           Otherwise, ILO and IHI should be set to 1 and N,
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and WANTT is .TRUE., then H
+*           contains the upper triangular matrix T from the Schur
+*           decomposition (the Schur form). If INFO = 0 and WANT is
+*           .FALSE., then the contents of H are unspecified on exit.
+*           (The output value of H when INFO.GT.0 is given under the
+*           description of INFO below.)
+*
+*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     W        (output) COMPLEX*16 array, dimension (N)
+*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
+*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
+*           stored in the same order as on the diagonal of the Schur
+*           form returned in H, with W(i) = H(i,i).
+*
+*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,IHI)
+*           If WANTZ is .FALSE., then Z is not referenced.
+*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*           (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if WANTZ is .TRUE.
+*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) COMPLEX*16 array, dimension LWORK
+*           On exit, if LWORK = -1, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then ZLAQR0 does a workspace query.
+*           In this case, ZLAQR0 checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .GT. 0:  if INFO = i, ZLAQR0 failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*                the remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is a unitary matrix.  The final
+*                value of  H is upper Hessenberg and triangular in
+*                rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of WANTT.)
+*
+*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*                accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    ZLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== Exceptional deflation windows:  try to cure rare
+*     .    slow convergence by increasing the size of the
+*     .    deflation window after KEXNW iterations. =====
+*
+*     ==== Exceptional shifts: try to cure rare slow convergence
+*     .    with ad-hoc exceptional shifts every KEXSH iterations.
+*     .    The constants WILK1 and WILK2 are used to form the
+*     .    exceptional shifts. ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            KEXNW, KEXSH
+      PARAMETER          ( KEXNW = 5, KEXSH = 6 )
+      DOUBLE PRECISION   WILK1
+      PARAMETER          ( WILK1 = 0.75d0 )
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+      DOUBLE PRECISION   S
+      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+     $                   LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+     $                   NSR, NVE, NW, NWMAX, NWR
+      LOGICAL            NWINC, SORTED
+      CHARACTER          JBCMPZ*2
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLACPY, ZLAHQR, ZLAQR3, ZLAQR4, ZLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+*
+*     ==== Quick return for N = 0: nothing to do. ====
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+*
+*     ==== Set up job flags for ILAENV. ====
+*
+      IF( WANTT ) THEN
+         JBCMPZ( 1: 1 ) = 'S'
+      ELSE
+         JBCMPZ( 1: 1 ) = 'E'
+      END IF
+      IF( WANTZ ) THEN
+         JBCMPZ( 2: 2 ) = 'V'
+      ELSE
+         JBCMPZ( 2: 2 ) = 'N'
+      END IF
+*
+*     ==== Tiny matrices must use ZLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, INFO )
+      ELSE
+*
+*        ==== Use small bulge multi-shift QR with aggressive early
+*        .    deflation on larger-than-tiny matrices. ====
+*
+*        ==== Hope for the best. ====
+*
+         INFO = 0
+*
+*        ==== NWR = recommended deflation window size.  At this
+*        .    point,  N .GT. NTINY = 11, so there is enough
+*        .    subdiagonal workspace for NWR.GE.2 as required.
+*        .    (In fact, there is enough subdiagonal space for
+*        .    NWR.GE.3.) ====
+*
+         NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NWR = MAX( 2, NWR )
+         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+         NW = NWR
+*
+*        ==== NSR = recommended number of simultaneous shifts.
+*        .    At this point N .GT. NTINY = 11, so there is at
+*        .    enough subdiagonal workspace for NSR to be even
+*        .    and greater than or equal to two as required. ====
+*
+         NSR = ILAENV( 15, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+*        ==== Estimate optimal workspace ====
+*
+*        ==== Workspace query call to ZLAQR3 ====
+*
+         CALL ZLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+     $                IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
+     $                LDH, WORK, -1 )
+*
+*        ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+            RETURN
+         END IF
+*
+*        ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         NIBBLE = MAX( 0, NIBBLE )
+*
+*        ==== Accumulate reflections during ttswp?  Use block
+*        .    2-by-2 structure during matrix-matrix multiply? ====
+*
+         KACC22 = ILAENV( 16, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+         KACC22 = MAX( 0, KACC22 )
+         KACC22 = MIN( 2, KACC22 )
+*
+*        ==== NWMAX = the largest possible deflation window for
+*        .    which there is sufficient workspace. ====
+*
+         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+*        ==== NSMAX = the Largest number of simultaneous shifts
+*        .    for which there is sufficient workspace. ====
+*
+         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+         NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+*        ==== NDFL: an iteration count restarted at deflation. ====
+*
+         NDFL = 1
+*
+*        ==== ITMAX = iteration limit ====
+*
+         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+*        ==== Last row and column in the active block ====
+*
+         KBOT = IHI
+*
+*        ==== Main Loop ====
+*
+         DO 70 IT = 1, ITMAX
+*
+*           ==== Done when KBOT falls below ILO ====
+*
+            IF( KBOT.LT.ILO )
+     $         GO TO 80
+*
+*           ==== Locate active block ====
+*
+            DO 10 K = KBOT, ILO + 1, -1
+               IF( H( K, K-1 ).EQ.ZERO )
+     $            GO TO 20
+   10       CONTINUE
+            K = ILO
+   20       CONTINUE
+            KTOP = K
+*
+*           ==== Select deflation window size ====
+*
+            NH = KBOT - KTOP + 1
+            IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+*              ==== Typical deflation window.  If possible and
+*              .    advisable, nibble the entire active block.
+*              .    If not, use size NWR or NWR+1 depending upon
+*              .    which has the smaller corresponding subdiagonal
+*              .    entry (a heuristic). ====
+*
+               NWINC = .TRUE.
+               IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+                  NW = NH
+               ELSE
+                  NW = MIN( NWR, NH, NWMAX )
+                  IF( NW.LT.NWMAX ) THEN
+                     IF( NW.GE.NH-1 ) THEN
+                        NW = NH
+                     ELSE
+                        KWTOP = KBOT - NW + 1
+                        IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
+     $                      CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+                     END IF
+                  END IF
+               END IF
+            ELSE
+*
+*              ==== Exceptional deflation window.  If there have
+*              .    been no deflations in KEXNW or more iterations,
+*              .    then vary the deflation window size.   At first,
+*              .    because, larger windows are, in general, more
+*              .    powerful than smaller ones, rapidly increase the
+*              .    window up to the maximum reasonable and possible.
+*              .    Then maybe try a slightly smaller window.  ====
+*
+               IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+                  NW = MIN( NWMAX, NH, 2*NW )
+               ELSE
+                  NWINC = .FALSE.
+                  IF( NW.EQ.NH .AND. NH.GT.2 )
+     $               NW = NH - 1
+               END IF
+            END IF
+*
+*           ==== Aggressive early deflation:
+*           .    split workspace under the subdiagonal into
+*           .      - an nw-by-nw work array V in the lower
+*           .        left-hand-corner,
+*           .      - an NW-by-at-least-NW-but-more-is-better
+*           .        (NW-by-NHO) horizontal work array along
+*           .        the bottom edge,
+*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
+*           .        vertical work array along the left-hand-edge.
+*           .        ====
+*
+            KV = N - NW + 1
+            KT = NW + 1
+            NHO = ( N-NW-1 ) - KT + 1
+            KWV = NW + 2
+            NVE = ( N-NW ) - KWV + 1
+*
+*           ==== Aggressive early deflation ====
+*
+            CALL ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
+     $                   H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
+     $                   LWORK )
+*
+*           ==== Adjust KBOT accounting for new deflations. ====
+*
+            KBOT = KBOT - LD
+*
+*           ==== KS points to the shifts. ====
+*
+            KS = KBOT - LS + 1
+*
+*           ==== Skip an expensive QR sweep if there is a (partly
+*           .    heuristic) reason to expect that many eigenvalues
+*           .    will deflate without it.  Here, the QR sweep is
+*           .    skipped if many eigenvalues have just been deflated
+*           .    or if the remaining active block is small.
+*
+            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+*              ==== NS = nominal number of simultaneous shifts.
+*              .    This may be lowered (slightly) if ZLAQR3
+*              .    did not provide that many shifts. ====
+*
+               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+               NS = NS - MOD( NS, 2 )
+*
+*              ==== If there have been no deflations
+*              .    in a multiple of KEXSH iterations,
+*              .    then try exceptional shifts.
+*              .    Otherwise use shifts provided by
+*              .    ZLAQR3 above or from the eigenvalues
+*              .    of a trailing principal submatrix. ====
+*
+               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+                  KS = KBOT - NS + 1
+                  DO 30 I = KBOT, KS + 1, -2
+                     W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
+                     W( I-1 ) = W( I )
+   30             CONTINUE
+               ELSE
+*
+*                 ==== Got NS/2 or fewer shifts? Use ZLAQR4 or
+*                 .    ZLAHQR on a trailing principal submatrix to
+*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+*                 .    there is enough space below the subdiagonal
+*                 .    to fit an NS-by-NS scratch array.) ====
+*
+                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
+                     KS = KBOT - NS + 1
+                     KT = N - NS + 1
+                     CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     IF( NS.GT.NMIN ) THEN
+                        CALL ZLAQR4( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, W( KS ), 1, 1,
+     $                               ZDUM, 1, WORK, LWORK, INF )
+                     ELSE
+                        CALL ZLAHQR( .false., .false., NS, 1, NS,
+     $                               H( KT, 1 ), LDH, W( KS ), 1, 1,
+     $                               ZDUM, 1, INF )
+                     END IF
+                     KS = KS + INF
+*
+*                    ==== In case of a rare QR failure use
+*                    .    eigenvalues of the trailing 2-by-2
+*                    .    principal submatrix.  Scale to avoid
+*                    .    overflows, underflows and subnormals.
+*                    .    (The scale factor S can not be zero,
+*                    .    because H(KBOT,KBOT-1) is nonzero.) ====
+*
+                     IF( KS.GE.KBOT ) THEN
+                        S = CABS1( H( KBOT-1, KBOT-1 ) ) +
+     $                      CABS1( H( KBOT, KBOT-1 ) ) +
+     $                      CABS1( H( KBOT-1, KBOT ) ) +
+     $                      CABS1( H( KBOT, KBOT ) )
+                        AA = H( KBOT-1, KBOT-1 ) / S
+                        CC = H( KBOT, KBOT-1 ) / S
+                        BB = H( KBOT-1, KBOT ) / S
+                        DD = H( KBOT, KBOT ) / S
+                        TR2 = ( AA+DD ) / TWO
+                        DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
+                        RTDISC = SQRT( -DET )
+                        W( KBOT-1 ) = ( TR2+RTDISC )*S
+                        W( KBOT ) = ( TR2-RTDISC )*S
+*
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little) ====
+*
+                     SORTED = .false.
+                     DO 50 K = KBOT, KS + 1, -1
+                        IF( SORTED )
+     $                     GO TO 60
+                        SORTED = .true.
+                        DO 40 I = KS, K - 1
+                           IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
+     $                          THEN
+                              SORTED = .false.
+                              SWAP = W( I )
+                              W( I ) = W( I+1 )
+                              W( I+1 ) = SWAP
+                           END IF
+   40                   CONTINUE
+   50                CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+*
+*              ==== If there are only two shifts, then use
+*              .    only one.  ====
+*
+               IF( KBOT-KS+1.EQ.2 ) THEN
+                  IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
+     $                CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+                     W( KBOT-1 ) = W( KBOT )
+                  ELSE
+                     W( KBOT ) = W( KBOT-1 )
+                  END IF
+               END IF
+*
+*              ==== Use up to NS of the the smallest magnatiude
+*              .    shifts.  If there aren't NS shifts available,
+*              .    then use them all, possibly dropping one to
+*              .    make the number of shifts even. ====
+*
+               NS = MIN( NS, KBOT-KS+1 )
+               NS = NS - MOD( NS, 2 )
+               KS = KBOT - NS + 1
+*
+*              ==== Small-bulge multi-shift QR sweep:
+*              .    split workspace under the subdiagonal into
+*              .    - a KDU-by-KDU work array U in the lower
+*              .      left-hand-corner,
+*              .    - a KDU-by-at-least-KDU-but-more-is-better
+*              .      (KDU-by-NHo) horizontal work array WH along
+*              .      the bottom edge,
+*              .    - and an at-least-KDU-but-more-is-better-by-KDU
+*              .      (NVE-by-KDU) vertical work WV arrow along
+*              .      the left-hand-edge. ====
+*
+               KDU = 3*NS - 3
+               KU = N - KDU + 1
+               KWH = KDU + 1
+               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+               KWV = KDU + 4
+               NVE = N - KDU - KWV + 1
+*
+*              ==== Small-bulge multi-shift QR sweep ====
+*
+               CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+     $                      W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
+     $                      3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
+     $                      NHO, H( KU, KWH ), LDH )
+            END IF
+*
+*           ==== Note progress (or the lack of it). ====
+*
+            IF( LD.GT.0 ) THEN
+               NDFL = 1
+            ELSE
+               NDFL = NDFL + 1
+            END IF
+*
+*           ==== End of main loop ====
+   70    CONTINUE
+*
+*        ==== Iteration limit exceeded.  Set INFO to show where
+*        .    the problem occurred and exit. ====
+*
+         INFO = KBOT
+   80    CONTINUE
+      END IF
+*
+*     ==== Return the optimal value of LWORK. ====
+*
+      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+*
+*     ==== End of ZLAQR0 ====
+*
+      END
diff --git a/src/lib/lapack/zlaqr1.f b/src/lib/lapack/zlaqr1.f
new file mode 100644
index 00000000..b8c1c3d4
--- /dev/null
+++ b/src/lib/lapack/zlaqr1.f
@@ -0,0 +1,97 @@
+      SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      COMPLEX*16         S1, S2
+      INTEGER            LDH, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), V( * )
+*     ..
+*
+*       Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a
+*       scalar multiple of the first column of the product
+*
+*       (*)  K = (H - s1*I)*(H - s2*I)
+*
+*       scaling to avoid overflows and most underflows.
+*
+*       This is useful for starting double implicit shift bulges
+*       in the QR algorithm.
+*
+*
+*       N      (input) integer
+*              Order of the matrix H. N must be either 2 or 3.
+*
+*       H      (input) COMPLEX*16 array of dimension (LDH,N)
+*              The 2-by-2 or 3-by-3 matrix H in (*).
+*
+*       LDH    (input) integer
+*              The leading dimension of H as declared in
+*              the calling procedure.  LDH.GE.N
+*
+*       S1     (input) COMPLEX*16
+*       S2     S1 and S2 are the shifts defining K in (*) above.
+*
+*       V      (output) COMPLEX*16 array of dimension N
+*              A scalar multiple of the first column of the
+*              matrix K in (*).
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO
+      PARAMETER          ( RZERO = 0.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         CDUM
+      DOUBLE PRECISION   H21S, H31S, S
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+      IF( N.EQ.2 ) THEN
+         S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) )
+         IF( S.EQ.RZERO ) THEN
+            V( 1 ) = ZERO
+            V( 2 ) = ZERO
+         ELSE
+            H21S = H( 2, 1 ) / S
+            V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-S1 )*
+     $               ( ( H( 1, 1 )-S2 ) / S )
+            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 )
+         END IF
+      ELSE
+         S = CABS1( H( 1, 1 )-S2 ) + CABS1( H( 2, 1 ) ) +
+     $       CABS1( H( 3, 1 ) )
+         IF( S.EQ.ZERO ) THEN
+            V( 1 ) = ZERO
+            V( 2 ) = ZERO
+            V( 3 ) = ZERO
+         ELSE
+            H21S = H( 2, 1 ) / S
+            H31S = H( 3, 1 ) / S
+            V( 1 ) = ( H( 1, 1 )-S1 )*( ( H( 1, 1 )-S2 ) / S ) +
+     $               H( 1, 2 )*H21S + H( 1, 3 )*H31S
+            V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-S1-S2 ) + H( 2, 3 )*H31S
+            V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-S1-S2 ) + H21S*H( 3, 2 )
+         END IF
+      END IF
+      END
diff --git a/src/lib/lapack/zlaqr2.f b/src/lib/lapack/zlaqr2.f
new file mode 100644
index 00000000..0add51ae
--- /dev/null
+++ b/src/lib/lapack/zlaqr2.f
@@ -0,0 +1,437 @@
+      SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+     $                   NV, WV, LDWV, WORK, LWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
+*     ..
+*
+*     This subroutine is identical to ZLAQR3 except that it avoids
+*     recursion by calling ZLAHQR instead of ZLAQR4.
+*
+*
+*     ******************************************************************
+*     Aggressive early deflation:
+*
+*     This subroutine accepts as input an upper Hessenberg matrix
+*     H and performs an unitary similarity transformation
+*     designed to detect and deflate fully converged eigenvalues from
+*     a trailing principal submatrix.  On output H has been over-
+*     written by a new Hessenberg matrix that is a perturbation of
+*     an unitary similarity transformation of H.  It is to be
+*     hoped that the final version of H has many zero subdiagonal
+*     entries.
+*
+*     ******************************************************************
+*     WANTT   (input) LOGICAL
+*          If .TRUE., then the Hessenberg matrix H is fully updated
+*          so that the triangular Schur factor may be
+*          computed (in cooperation with the calling subroutine).
+*          If .FALSE., then only enough of H is updated to preserve
+*          the eigenvalues.
+*
+*     WANTZ   (input) LOGICAL
+*          If .TRUE., then the unitary matrix Z is updated so
+*          so that the unitary Schur factor may be computed
+*          (in cooperation with the calling subroutine).
+*          If .FALSE., then Z is not referenced.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H and (if WANTZ is .TRUE.) the
+*          order of the unitary matrix Z.
+*
+*     KTOP    (input) INTEGER
+*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*          KBOT and KTOP together determine an isolated block
+*          along the diagonal of the Hessenberg matrix.
+*
+*     KBOT    (input) INTEGER
+*          It is assumed without a check that either
+*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
+*          determine an isolated block along the diagonal of the
+*          Hessenberg matrix.
+*
+*     NW      (input) INTEGER
+*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)
+*          On input the initial N-by-N section of H stores the
+*          Hessenberg matrix undergoing aggressive early deflation.
+*          On output H has been transformed by a unitary
+*          similarity transformation, perturbed, and the returned
+*          to Hessenberg form that (it is to be hoped) has some
+*          zero subdiagonal entries.
+*
+*     LDH     (input) integer
+*          Leading dimension of H just as declared in the calling
+*          subroutine.  N .LE. LDH
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,IHI)
+*          IF WANTZ is .TRUE., then on output, the unitary
+*          similarity transformation mentioned above has been
+*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*          If WANTZ is .FALSE., then Z is unreferenced.
+*
+*     LDZ     (input) integer
+*          The leading dimension of Z just as declared in the
+*          calling subroutine.  1 .LE. LDZ.
+*
+*     NS      (output) integer
+*          The number of unconverged (ie approximate) eigenvalues
+*          returned in SR and SI that may be used as shifts by the
+*          calling subroutine.
+*
+*     ND      (output) integer
+*          The number of converged eigenvalues uncovered by this
+*          subroutine.
+*
+*     SH      (output) COMPLEX*16 array, dimension KBOT
+*          On output, approximate eigenvalues that may
+*          be used for shifts are stored in SH(KBOT-ND-NS+1)
+*          through SR(KBOT-ND).  Converged eigenvalues are
+*          stored in SH(KBOT-ND+1) through SH(KBOT).
+*
+*     V       (workspace) COMPLEX*16 array, dimension (LDV,NW)
+*          An NW-by-NW work array.
+*
+*     LDV     (input) integer scalar
+*          The leading dimension of V just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     NH      (input) integer scalar
+*          The number of columns of T.  NH.GE.NW.
+*
+*     T       (workspace) COMPLEX*16 array, dimension (LDT,NW)
+*
+*     LDT     (input) integer
+*          The leading dimension of T just as declared in the
+*          calling subroutine.  NW .LE. LDT
+*
+*     NV      (input) integer
+*          The number of rows of work array WV available for
+*          workspace.  NV.GE.NW.
+*
+*     WV      (workspace) COMPLEX*16 array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) COMPLEX*16 array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (input) integer
+*          The dimension of the work array WORK.  LWORK = 2*NW
+*          suffices, but greater efficiency may result from larger
+*          values of LWORK.
+*
+*          If LWORK = -1, then a workspace query is assumed; ZLAQR2
+*          only estimates the optimal workspace size for the given
+*          values of N, NW, KTOP and KBOT.  The estimate is returned
+*          in WORK(1).  No error message related to LWORK is issued
+*          by XERBLA.  Neither H nor Z are accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ==================================================================
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO, RONE
+      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         BETA, CDUM, S, TAU
+      DOUBLE PRECISION   FOO, SAFMAX, SAFMIN, SMLNUM, ULP
+      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
+     $                   KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
+     $                   ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to ZGEHRD ====
+*
+         CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to ZUNGHR ====
+*
+         CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Optimal workspace ====
+*
+         LWKOPT = JW + MAX( LWK1, LWK2 )
+      END IF
+*
+*     ==== Quick return in case of workspace query. ====
+*
+      IF( LWORK.EQ.-1 ) THEN
+         WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+         RETURN
+      END IF
+*
+*     ==== Nothing to do ...
+*     ... for an empty active block ... ====
+      NS = 0
+      ND = 0
+      IF( KTOP.GT.KBOT )
+     $   RETURN
+*     ... nor for an empty deflation window. ====
+      IF( NW.LT.1 )
+     $   RETURN
+*
+*     ==== Machine constants ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Setup deflation window ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      KWTOP = KBOT - JW + 1
+      IF( KWTOP.EQ.KTOP ) THEN
+         S = ZERO
+      ELSE
+         S = H( KWTOP, KWTOP-1 )
+      END IF
+*
+      IF( KBOT.EQ.KWTOP ) THEN
+*
+*        ==== 1-by-1 deflation window: not much to do ====
+*
+         SH( KWTOP ) = H( KWTOP, KWTOP )
+         NS = 1
+         ND = 0
+         IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
+     $       KWTOP ) ) ) ) THEN
+            NS = 0
+            ND = 1
+            IF( KWTOP.GT.KTOP )
+     $         H( KWTOP, KWTOP-1 ) = ZERO
+         END IF
+         RETURN
+      END IF
+*
+*     ==== Convert to spike-triangular form.  (In case of a
+*     .    rare QR failure, this routine continues to do
+*     .    aggressive early deflation using that part of
+*     .    the deflation window that converged using INFQR
+*     .    here and there to keep track.) ====
+*
+      CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+     $             JW, V, LDV, INFQR )
+*
+*     ==== Deflation detection loop ====
+*
+      NS = JW
+      ILST = INFQR + 1
+      DO 10 KNT = INFQR + 1, JW
+*
+*        ==== Small spike tip deflation test ====
+*
+         FOO = CABS1( T( NS, NS ) )
+         IF( FOO.EQ.RZERO )
+     $      FOO = CABS1( S )
+         IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
+     $        THEN
+*
+*           ==== One more converged eigenvalue ====
+*
+            NS = NS - 1
+         ELSE
+*
+*           ==== One undflatable eigenvalue.  Move it up out of the
+*           .    way.   (ZTREXC can not fail in this case.) ====
+*
+            IFST = NS
+            CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+            ILST = ILST + 1
+         END IF
+   10 CONTINUE
+*
+*        ==== Return to Hessenberg form ====
+*
+      IF( NS.EQ.0 )
+     $   S = ZERO
+*
+      IF( NS.LT.JW ) THEN
+*
+*        ==== sorting the diagonal of T improves accuracy for
+*        .    graded matrices.  ====
+*
+         DO 30 I = INFQR + 1, NS
+            IFST = I
+            DO 20 J = I + 1, NS
+               IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
+     $            IFST = J
+   20       CONTINUE
+            ILST = I
+            IF( IFST.NE.ILST )
+     $         CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+   30    CONTINUE
+      END IF
+*
+*     ==== Restore shift/eigenvalue array from T ====
+*
+      DO 40 I = INFQR + 1, JW
+         SH( KWTOP+I-1 ) = T( I, I )
+   40 CONTINUE
+*
+*
+      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+*           ==== Reflect spike back into lower triangle ====
+*
+            CALL ZCOPY( NS, V, LDV, WORK, 1 )
+            DO 50 I = 1, NS
+               WORK( I ) = DCONJG( WORK( I ) )
+   50       CONTINUE
+            BETA = WORK( 1 )
+            CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+         END IF
+*
+*        ==== Copy updated reduced window into place ====
+*
+         IF( KWTOP.GT.1 )
+     $      H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
+         CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+     $               LDH+1 )
+*
+*        ==== Accumulate orthogonal matrix in order update
+*        .    H and Z, if requested.  (A modified version
+*        .    of  ZUNGHR that accumulates block Householder
+*        .    transformations into V directly might be
+*        .    marginally more efficient than the following.) ====
+*
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+            CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+         END IF
+*
+*        ==== Update vertical slab in H ====
+*
+         IF( WANTT ) THEN
+            LTOP = 1
+         ELSE
+            LTOP = KTOP
+         END IF
+         DO 60 KROW = LTOP, KWTOP - 1, NV
+            KLN = MIN( NV, KWTOP-KROW )
+            CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+   60    CONTINUE
+*
+*        ==== Update horizontal slab in H ====
+*
+         IF( WANTT ) THEN
+            DO 70 KCOL = KBOT + 1, N, NH
+               KLN = MIN( NH, N-KCOL+1 )
+               CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+     $                      LDH )
+   70       CONTINUE
+         END IF
+*
+*        ==== Update vertical slab in Z ====
+*
+         IF( WANTZ ) THEN
+            DO 80 KROW = ILOZ, IHIZ, NV
+               KLN = MIN( NV, IHIZ-KROW+1 )
+               CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+     $                      LDZ )
+   80       CONTINUE
+         END IF
+      END IF
+*
+*     ==== Return the number of deflations ... ====
+*
+      ND = JW - NS
+*
+*     ==== ... and the number of shifts. (Subtracting
+*     .    INFQR from the spike length takes care
+*     .    of the case of a rare QR failure while
+*     .    calculating eigenvalues of the deflation
+*     .    window.)  ====
+*
+      NS = NS - INFQR
+*
+*      ==== Return optimal workspace. ====
+*
+      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+*
+*     ==== End of ZLAQR2 ====
+*
+      END
diff --git a/src/lib/lapack/zlaqr3.f b/src/lib/lapack/zlaqr3.f
new file mode 100644
index 00000000..e9bf393a
--- /dev/null
+++ b/src/lib/lapack/zlaqr3.f
@@ -0,0 +1,448 @@
+      SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT,
+     $                   NV, WV, LDWV, WORK, LWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+     $                   LDZ, LWORK, N, ND, NH, NS, NV, NW
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( * ), WV( LDWV, * ), Z( LDZ, * )
+*     ..
+*
+*     ******************************************************************
+*     Aggressive early deflation:
+*
+*     This subroutine accepts as input an upper Hessenberg matrix
+*     H and performs an unitary similarity transformation
+*     designed to detect and deflate fully converged eigenvalues from
+*     a trailing principal submatrix.  On output H has been over-
+*     written by a new Hessenberg matrix that is a perturbation of
+*     an unitary similarity transformation of H.  It is to be
+*     hoped that the final version of H has many zero subdiagonal
+*     entries.
+*
+*     ******************************************************************
+*     WANTT   (input) LOGICAL
+*          If .TRUE., then the Hessenberg matrix H is fully updated
+*          so that the triangular Schur factor may be
+*          computed (in cooperation with the calling subroutine).
+*          If .FALSE., then only enough of H is updated to preserve
+*          the eigenvalues.
+*
+*     WANTZ   (input) LOGICAL
+*          If .TRUE., then the unitary matrix Z is updated so
+*          so that the unitary Schur factor may be computed
+*          (in cooperation with the calling subroutine).
+*          If .FALSE., then Z is not referenced.
+*
+*     N       (input) INTEGER
+*          The order of the matrix H and (if WANTZ is .TRUE.) the
+*          order of the unitary matrix Z.
+*
+*     KTOP    (input) INTEGER
+*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+*          KBOT and KTOP together determine an isolated block
+*          along the diagonal of the Hessenberg matrix.
+*
+*     KBOT    (input) INTEGER
+*          It is assumed without a check that either
+*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
+*          determine an isolated block along the diagonal of the
+*          Hessenberg matrix.
+*
+*     NW      (input) INTEGER
+*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)
+*          On input the initial N-by-N section of H stores the
+*          Hessenberg matrix undergoing aggressive early deflation.
+*          On output H has been transformed by a unitary
+*          similarity transformation, perturbed, and the returned
+*          to Hessenberg form that (it is to be hoped) has some
+*          zero subdiagonal entries.
+*
+*     LDH     (input) integer
+*          Leading dimension of H just as declared in the calling
+*          subroutine.  N .LE. LDH
+*
+*     ILOZ    (input) INTEGER
+*     IHIZ    (input) INTEGER
+*          Specify the rows of Z to which transformations must be
+*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,IHI)
+*          IF WANTZ is .TRUE., then on output, the unitary
+*          similarity transformation mentioned above has been
+*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*          If WANTZ is .FALSE., then Z is unreferenced.
+*
+*     LDZ     (input) integer
+*          The leading dimension of Z just as declared in the
+*          calling subroutine.  1 .LE. LDZ.
+*
+*     NS      (output) integer
+*          The number of unconverged (ie approximate) eigenvalues
+*          returned in SR and SI that may be used as shifts by the
+*          calling subroutine.
+*
+*     ND      (output) integer
+*          The number of converged eigenvalues uncovered by this
+*          subroutine.
+*
+*     SH      (output) COMPLEX*16 array, dimension KBOT
+*          On output, approximate eigenvalues that may
+*          be used for shifts are stored in SH(KBOT-ND-NS+1)
+*          through SR(KBOT-ND).  Converged eigenvalues are
+*          stored in SH(KBOT-ND+1) through SH(KBOT).
+*
+*     V       (workspace) COMPLEX*16 array, dimension (LDV,NW)
+*          An NW-by-NW work array.
+*
+*     LDV     (input) integer scalar
+*          The leading dimension of V just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     NH      (input) integer scalar
+*          The number of columns of T.  NH.GE.NW.
+*
+*     T       (workspace) COMPLEX*16 array, dimension (LDT,NW)
+*
+*     LDT     (input) integer
+*          The leading dimension of T just as declared in the
+*          calling subroutine.  NW .LE. LDT
+*
+*     NV      (input) integer
+*          The number of rows of work array WV available for
+*          workspace.  NV.GE.NW.
+*
+*     WV      (workspace) COMPLEX*16 array, dimension (LDWV,NW)
+*
+*     LDWV    (input) integer
+*          The leading dimension of W just as declared in the
+*          calling subroutine.  NW .LE. LDV
+*
+*     WORK    (workspace) COMPLEX*16 array, dimension LWORK.
+*          On exit, WORK(1) is set to an estimate of the optimal value
+*          of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+*     LWORK   (input) integer
+*          The dimension of the work array WORK.  LWORK = 2*NW
+*          suffices, but greater efficiency may result from larger
+*          values of LWORK.
+*
+*          If LWORK = -1, then a workspace query is assumed; ZLAQR3
+*          only estimates the optimal workspace size for the given
+*          values of N, NW, KTOP and KBOT.  The estimate is returned
+*          in WORK(1).  No error message related to LWORK is issued
+*          by XERBLA.  Neither H nor Z are accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ==================================================================
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO, RONE
+      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         BETA, CDUM, S, TAU
+      DOUBLE PRECISION   FOO, SAFMAX, SAFMIN, SMLNUM, ULP
+      INTEGER            I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN,
+     $                   KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+     $                   LWKOPT, NMIN
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      INTEGER            ILAENV
+      EXTERNAL           DLAMCH, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR,
+     $                   ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== Estimate optimal workspace. ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      IF( JW.LE.2 ) THEN
+         LWKOPT = 1
+      ELSE
+*
+*        ==== Workspace query call to ZGEHRD ====
+*
+         CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK1 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to ZUNGHR ====
+*
+         CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+         LWK2 = INT( WORK( 1 ) )
+*
+*        ==== Workspace query call to ZLAQR4 ====
+*
+         CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V,
+     $                LDV, WORK, -1, INFQR )
+         LWK3 = INT( WORK( 1 ) )
+*
+*        ==== Optimal workspace ====
+*
+         LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
+      END IF
+*
+*     ==== Quick return in case of workspace query. ====
+*
+      IF( LWORK.EQ.-1 ) THEN
+         WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+         RETURN
+      END IF
+*
+*     ==== Nothing to do ...
+*     ... for an empty active block ... ====
+      NS = 0
+      ND = 0
+      IF( KTOP.GT.KBOT )
+     $   RETURN
+*     ... nor for an empty deflation window. ====
+      IF( NW.LT.1 )
+     $   RETURN
+*
+*     ==== Machine constants ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Setup deflation window ====
+*
+      JW = MIN( NW, KBOT-KTOP+1 )
+      KWTOP = KBOT - JW + 1
+      IF( KWTOP.EQ.KTOP ) THEN
+         S = ZERO
+      ELSE
+         S = H( KWTOP, KWTOP-1 )
+      END IF
+*
+      IF( KBOT.EQ.KWTOP ) THEN
+*
+*        ==== 1-by-1 deflation window: not much to do ====
+*
+         SH( KWTOP ) = H( KWTOP, KWTOP )
+         NS = 1
+         ND = 0
+         IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP,
+     $       KWTOP ) ) ) ) THEN
+
+            NS = 0
+            ND = 1
+            IF( KWTOP.GT.KTOP )
+     $         H( KWTOP, KWTOP-1 ) = ZERO
+         END IF
+         RETURN
+      END IF
+*
+*     ==== Convert to spike-triangular form.  (In case of a
+*     .    rare QR failure, this routine continues to do
+*     .    aggressive early deflation using that part of
+*     .    the deflation window that converged using INFQR
+*     .    here and there to keep track.) ====
+*
+      CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+      CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+      CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+      NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK )
+      IF( JW.GT.NMIN ) THEN
+         CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+     $                JW, V, LDV, WORK, LWORK, INFQR )
+      ELSE
+         CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1,
+     $                JW, V, LDV, INFQR )
+      END IF
+*
+*     ==== Deflation detection loop ====
+*
+      NS = JW
+      ILST = INFQR + 1
+      DO 10 KNT = INFQR + 1, JW
+*
+*        ==== Small spike tip deflation test ====
+*
+         FOO = CABS1( T( NS, NS ) )
+         IF( FOO.EQ.RZERO )
+     $      FOO = CABS1( S )
+         IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) )
+     $        THEN
+*
+*           ==== One more converged eigenvalue ====
+*
+            NS = NS - 1
+         ELSE
+*
+*           ==== One undflatable eigenvalue.  Move it up out of the
+*           .    way.   (ZTREXC can not fail in this case.) ====
+*
+            IFST = NS
+            CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+            ILST = ILST + 1
+         END IF
+   10 CONTINUE
+*
+*        ==== Return to Hessenberg form ====
+*
+      IF( NS.EQ.0 )
+     $   S = ZERO
+*
+      IF( NS.LT.JW ) THEN
+*
+*        ==== sorting the diagonal of T improves accuracy for
+*        .    graded matrices.  ====
+*
+         DO 30 I = INFQR + 1, NS
+            IFST = I
+            DO 20 J = I + 1, NS
+               IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) )
+     $            IFST = J
+   20       CONTINUE
+            ILST = I
+            IF( IFST.NE.ILST )
+     $         CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO )
+   30    CONTINUE
+      END IF
+*
+*     ==== Restore shift/eigenvalue array from T ====
+*
+      DO 40 I = INFQR + 1, JW
+         SH( KWTOP+I-1 ) = T( I, I )
+   40 CONTINUE
+*
+*
+      IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+*           ==== Reflect spike back into lower triangle ====
+*
+            CALL ZCOPY( NS, V, LDV, WORK, 1 )
+            DO 50 I = 1, NS
+               WORK( I ) = DCONJG( WORK( I ) )
+   50       CONTINUE
+            BETA = WORK( 1 )
+            CALL ZLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+            WORK( 1 ) = ONE
+*
+            CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+            CALL ZLARF( 'L', NS, JW, WORK, 1, DCONJG( TAU ), T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL ZLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+     $                  WORK( JW+1 ) )
+            CALL ZLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+     $                  WORK( JW+1 ) )
+*
+            CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+         END IF
+*
+*        ==== Copy updated reduced window into place ====
+*
+         IF( KWTOP.GT.1 )
+     $      H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) )
+         CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+         CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+     $               LDH+1 )
+*
+*        ==== Accumulate orthogonal matrix in order update
+*        .    H and Z, if requested.  (A modified version
+*        .    of  ZUNGHR that accumulates block Householder
+*        .    transformations into V directly might be
+*        .    marginally more efficient than the following.) ====
+*
+         IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+            CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+     $                   LWORK-JW, INFO )
+            CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+     $                  WV, LDWV )
+            CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+         END IF
+*
+*        ==== Update vertical slab in H ====
+*
+         IF( WANTT ) THEN
+            LTOP = 1
+         ELSE
+            LTOP = KTOP
+         END IF
+         DO 60 KROW = LTOP, KWTOP - 1, NV
+            KLN = MIN( NV, KWTOP-KROW )
+            CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+     $                  LDH, V, LDV, ZERO, WV, LDWV )
+            CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+   60    CONTINUE
+*
+*        ==== Update horizontal slab in H ====
+*
+         IF( WANTT ) THEN
+            DO 70 KCOL = KBOT + 1, N, NH
+               KLN = MIN( NH, N-KCOL+1 )
+               CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+     $                     H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+               CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+     $                      LDH )
+   70       CONTINUE
+         END IF
+*
+*        ==== Update vertical slab in Z ====
+*
+         IF( WANTZ ) THEN
+            DO 80 KROW = ILOZ, IHIZ, NV
+               KLN = MIN( NV, IHIZ-KROW+1 )
+               CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+     $                     LDZ, V, LDV, ZERO, WV, LDWV )
+               CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+     $                      LDZ )
+   80       CONTINUE
+         END IF
+      END IF
+*
+*     ==== Return the number of deflations ... ====
+*
+      ND = JW - NS
+*
+*     ==== ... and the number of shifts. (Subtracting
+*     .    INFQR from the spike length takes care
+*     .    of the case of a rare QR failure while
+*     .    calculating eigenvalues of the deflation
+*     .    window.)  ====
+*
+      NS = NS - INFQR
+*
+*      ==== Return optimal workspace. ====
+*
+      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+*
+*     ==== End of ZLAQR3 ====
+*
+      END
diff --git a/src/lib/lapack/zlaqr4.f b/src/lib/lapack/zlaqr4.f
new file mode 100644
index 00000000..eef7f00a
--- /dev/null
+++ b/src/lib/lapack/zlaqr4.f
@@ -0,0 +1,602 @@
+      SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*     This subroutine implements one level of recursion for ZLAQR0.
+*     It is a complete implementation of the small bulge multi-shift
+*     QR algorithm.  It may be called by ZLAQR0 and, for large enough
+*     deflation window size, it may be called by ZLAQR3.  This
+*     subroutine is identical to ZLAQR0 except that it calls ZLAQR2
+*     instead of ZLAQR3.
+*
+*     Purpose
+*     =======
+*
+*     ZLAQR4 computes the eigenvalues of a Hessenberg matrix H
+*     and, optionally, the matrices T and Z from the Schur decomposition
+*     H = Z T Z**H, where T is an upper triangular matrix (the
+*     Schur form), and Z is the unitary matrix of Schur vectors.
+*
+*     Optionally Z may be postmultiplied into an input unitary
+*     matrix Q so that this routine can give the Schur factorization
+*     of a matrix A which has been reduced to the Hessenberg form H
+*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.
+*
+*     Arguments
+*     =========
+*
+*     WANTT   (input) LOGICAL
+*          = .TRUE. : the full Schur form T is required;
+*          = .FALSE.: only eigenvalues are required.
+*
+*     WANTZ   (input) LOGICAL
+*          = .TRUE. : the matrix of Schur vectors Z is required;
+*          = .FALSE.: Schur vectors are not required.
+*
+*     N     (input) INTEGER
+*           The order of the matrix H.  N .GE. 0.
+*
+*     ILO   (input) INTEGER
+*     IHI   (input) INTEGER
+*           It is assumed that H is already upper triangular in rows
+*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+*           previous call to ZGEBAL, and then passed to ZGEHRD when the
+*           matrix output by ZGEBAL is reduced to Hessenberg form.
+*           Otherwise, ILO and IHI should be set to 1 and N,
+*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+*           If N = 0, then ILO = 1 and IHI = 0.
+*
+*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)
+*           On entry, the upper Hessenberg matrix H.
+*           On exit, if INFO = 0 and WANTT is .TRUE., then H
+*           contains the upper triangular matrix T from the Schur
+*           decomposition (the Schur form). If INFO = 0 and WANT is
+*           .FALSE., then the contents of H are unspecified on exit.
+*           (The output value of H when INFO.GT.0 is given under the
+*           description of INFO below.)
+*
+*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+*     LDH   (input) INTEGER
+*           The leading dimension of the array H. LDH .GE. max(1,N).
+*
+*     W        (output) COMPLEX*16 array, dimension (N)
+*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored
+*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are
+*           stored in the same order as on the diagonal of the Schur
+*           form returned in H, with W(i) = H(i,i).
+*
+*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,IHI)
+*           If WANTZ is .FALSE., then Z is not referenced.
+*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+*           (The output value of Z when INFO.GT.0 is given under
+*           the description of INFO below.)
+*
+*     LDZ   (input) INTEGER
+*           The leading dimension of the array Z.  if WANTZ is .TRUE.
+*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.
+*
+*     WORK  (workspace/output) COMPLEX*16 array, dimension LWORK
+*           On exit, if LWORK = -1, WORK(1) returns an estimate of
+*           the optimal value for LWORK.
+*
+*     LWORK (input) INTEGER
+*           The dimension of the array WORK.  LWORK .GE. max(1,N)
+*           is sufficient, but LWORK typically as large as 6*N may
+*           be required for optimal performance.  A workspace query
+*           to determine the optimal workspace size is recommended.
+*
+*           If LWORK = -1, then ZLAQR4 does a workspace query.
+*           In this case, ZLAQR4 checks the input parameters and
+*           estimates the optimal workspace size for the given
+*           values of N, ILO and IHI.  The estimate is returned
+*           in WORK(1).  No error message related to LWORK is
+*           issued by XERBLA.  Neither H nor Z are accessed.
+*
+*
+*     INFO  (output) INTEGER
+*             =  0:  successful exit
+*           .GT. 0:  if INFO = i, ZLAQR4 failed to compute all of
+*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR
+*                and WI contain those eigenvalues which have been
+*                successfully computed.  (Failures are rare.)
+*
+*                If INFO .GT. 0 and WANT is .FALSE., then on exit,
+*                the remaining unconverged eigenvalues are the eigen-
+*                values of the upper Hessenberg matrix rows and
+*                columns ILO through INFO of the final, output
+*                value of H.
+*
+*                If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+*           (*)  (initial value of H)*U  = U*(final value of H)
+*
+*                where U is a unitary matrix.  The final
+*                value of  H is upper Hessenberg and triangular in
+*                rows and columns INFO+1 through IHI.
+*
+*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)
+*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+*                where U is the unitary matrix in (*) (regard-
+*                less of the value of WANTT.)
+*
+*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+*                accessed.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*     ================================================================
+*     References:
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+*       929--947, 2002.
+*
+*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+*       of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+*     ================================================================
+*     .. Parameters ..
+*
+*     ==== Matrices of order NTINY or smaller must be processed by
+*     .    ZLAHQR because of insufficient subdiagonal scratch space.
+*     .    (This is a hard limit.) ====
+*
+*     ==== Exceptional deflation windows:  try to cure rare
+*     .    slow convergence by increasing the size of the
+*     .    deflation window after KEXNW iterations. =====
+*
+*     ==== Exceptional shifts: try to cure rare slow convergence
+*     .    with ad-hoc exceptional shifts every KEXSH iterations.
+*     .    The constants WILK1 and WILK2 are used to form the
+*     .    exceptional shifts. ====
+*
+      INTEGER            NTINY
+      PARAMETER          ( NTINY = 11 )
+      INTEGER            KEXNW, KEXSH
+      PARAMETER          ( KEXNW = 5, KEXSH = 6 )
+      DOUBLE PRECISION   WILK1
+      PARAMETER          ( WILK1 = 0.75d0 )
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   TWO
+      PARAMETER          ( TWO = 2.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         AA, BB, CC, CDUM, DD, DET, RTDISC, SWAP, TR2
+      DOUBLE PRECISION   S
+      INTEGER            I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+     $                   KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+     $                   LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+     $                   NSR, NVE, NW, NWMAX, NWR
+      LOGICAL            NWINC, SORTED
+      CHARACTER          JBCMPZ*2
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         ZDUM( 1, 1 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLACPY, ZLAHQR, ZLAQR2, ZLAQR5
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
+     $                   SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+      INFO = 0
+*
+*     ==== Quick return for N = 0: nothing to do. ====
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = ONE
+         RETURN
+      END IF
+*
+*     ==== Set up job flags for ILAENV. ====
+*
+      IF( WANTT ) THEN
+         JBCMPZ( 1: 1 ) = 'S'
+      ELSE
+         JBCMPZ( 1: 1 ) = 'E'
+      END IF
+      IF( WANTZ ) THEN
+         JBCMPZ( 2: 2 ) = 'V'
+      ELSE
+         JBCMPZ( 2: 2 ) = 'N'
+      END IF
+*
+*     ==== Tiny matrices must use ZLAHQR. ====
+*
+      IF( N.LE.NTINY ) THEN
+*
+*        ==== Estimate optimal workspace. ====
+*
+         LWKOPT = 1
+         IF( LWORK.NE.-1 )
+     $      CALL ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ,
+     $                   IHIZ, Z, LDZ, INFO )
+      ELSE
+*
+*        ==== Use small bulge multi-shift QR with aggressive early
+*        .    deflation on larger-than-tiny matrices. ====
+*
+*        ==== Hope for the best. ====
+*
+         INFO = 0
+*
+*        ==== NWR = recommended deflation window size.  At this
+*        .    point,  N .GT. NTINY = 11, so there is enough
+*        .    subdiagonal workspace for NWR.GE.2 as required.
+*        .    (In fact, there is enough subdiagonal space for
+*        .    NWR.GE.3.) ====
+*
+         NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NWR = MAX( 2, NWR )
+         NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+         NW = NWR
+*
+*        ==== NSR = recommended number of simultaneous shifts.
+*        .    At this point N .GT. NTINY = 11, so there is at
+*        .    enough subdiagonal workspace for NSR to be even
+*        .    and greater than or equal to two as required. ====
+*
+         NSR = ILAENV( 15, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+         NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+*        ==== Estimate optimal workspace ====
+*
+*        ==== Workspace query call to ZLAQR2 ====
+*
+         CALL ZLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+     $                IHIZ, Z, LDZ, LS, LD, W, H, LDH, N, H, LDH, N, H,
+     $                LDH, WORK, -1 )
+*
+*        ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ====
+*
+         LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+*        ==== Quick return in case of workspace query. ====
+*
+         IF( LWORK.EQ.-1 ) THEN
+            WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+            RETURN
+         END IF
+*
+*        ==== ZLAHQR/ZLAQR0 crossover point ====
+*
+         NMIN = ILAENV( 12, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NMIN = MAX( NTINY, NMIN )
+*
+*        ==== Nibble crossover point ====
+*
+         NIBBLE = ILAENV( 14, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         NIBBLE = MAX( 0, NIBBLE )
+*
+*        ==== Accumulate reflections during ttswp?  Use block
+*        .    2-by-2 structure during matrix-matrix multiply? ====
+*
+         KACC22 = ILAENV( 16, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+         KACC22 = MAX( 0, KACC22 )
+         KACC22 = MIN( 2, KACC22 )
+*
+*        ==== NWMAX = the largest possible deflation window for
+*        .    which there is sufficient workspace. ====
+*
+         NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+*        ==== NSMAX = the Largest number of simultaneous shifts
+*        .    for which there is sufficient workspace. ====
+*
+         NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+         NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+*        ==== NDFL: an iteration count restarted at deflation. ====
+*
+         NDFL = 1
+*
+*        ==== ITMAX = iteration limit ====
+*
+         ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+*        ==== Last row and column in the active block ====
+*
+         KBOT = IHI
+*
+*        ==== Main Loop ====
+*
+         DO 70 IT = 1, ITMAX
+*
+*           ==== Done when KBOT falls below ILO ====
+*
+            IF( KBOT.LT.ILO )
+     $         GO TO 80
+*
+*           ==== Locate active block ====
+*
+            DO 10 K = KBOT, ILO + 1, -1
+               IF( H( K, K-1 ).EQ.ZERO )
+     $            GO TO 20
+   10       CONTINUE
+            K = ILO
+   20       CONTINUE
+            KTOP = K
+*
+*           ==== Select deflation window size ====
+*
+            NH = KBOT - KTOP + 1
+            IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+*              ==== Typical deflation window.  If possible and
+*              .    advisable, nibble the entire active block.
+*              .    If not, use size NWR or NWR+1 depending upon
+*              .    which has the smaller corresponding subdiagonal
+*              .    entry (a heuristic). ====
+*
+               NWINC = .TRUE.
+               IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+                  NW = NH
+               ELSE
+                  NW = MIN( NWR, NH, NWMAX )
+                  IF( NW.LT.NWMAX ) THEN
+                     IF( NW.GE.NH-1 ) THEN
+                        NW = NH
+                     ELSE
+                        KWTOP = KBOT - NW + 1
+                        IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT.
+     $                      CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+                     END IF
+                  END IF
+               END IF
+            ELSE
+*
+*              ==== Exceptional deflation window.  If there have
+*              .    been no deflations in KEXNW or more iterations,
+*              .    then vary the deflation window size.   At first,
+*              .    because, larger windows are, in general, more
+*              .    powerful than smaller ones, rapidly increase the
+*              .    window up to the maximum reasonable and possible.
+*              .    Then maybe try a slightly smaller window.  ====
+*
+               IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+                  NW = MIN( NWMAX, NH, 2*NW )
+               ELSE
+                  NWINC = .FALSE.
+                  IF( NW.EQ.NH .AND. NH.GT.2 )
+     $               NW = NH - 1
+               END IF
+            END IF
+*
+*           ==== Aggressive early deflation:
+*           .    split workspace under the subdiagonal into
+*           .      - an nw-by-nw work array V in the lower
+*           .        left-hand-corner,
+*           .      - an NW-by-at-least-NW-but-more-is-better
+*           .        (NW-by-NHO) horizontal work array along
+*           .        the bottom edge,
+*           .      - an at-least-NW-but-more-is-better (NHV-by-NW)
+*           .        vertical work array along the left-hand-edge.
+*           .        ====
+*
+            KV = N - NW + 1
+            KT = NW + 1
+            NHO = ( N-NW-1 ) - KT + 1
+            KWV = NW + 2
+            NVE = ( N-NW ) - KWV + 1
+*
+*           ==== Aggressive early deflation ====
+*
+            CALL ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+     $                   IHIZ, Z, LDZ, LS, LD, W, H( KV, 1 ), LDH, NHO,
+     $                   H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH, WORK,
+     $                   LWORK )
+*
+*           ==== Adjust KBOT accounting for new deflations. ====
+*
+            KBOT = KBOT - LD
+*
+*           ==== KS points to the shifts. ====
+*
+            KS = KBOT - LS + 1
+*
+*           ==== Skip an expensive QR sweep if there is a (partly
+*           .    heuristic) reason to expect that many eigenvalues
+*           .    will deflate without it.  Here, the QR sweep is
+*           .    skipped if many eigenvalues have just been deflated
+*           .    or if the remaining active block is small.
+*
+            IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+     $          KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+*              ==== NS = nominal number of simultaneous shifts.
+*              .    This may be lowered (slightly) if ZLAQR2
+*              .    did not provide that many shifts. ====
+*
+               NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+               NS = NS - MOD( NS, 2 )
+*
+*              ==== If there have been no deflations
+*              .    in a multiple of KEXSH iterations,
+*              .    then try exceptional shifts.
+*              .    Otherwise use shifts provided by
+*              .    ZLAQR2 above or from the eigenvalues
+*              .    of a trailing principal submatrix. ====
+*
+               IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+                  KS = KBOT - NS + 1
+                  DO 30 I = KBOT, KS + 1, -2
+                     W( I ) = H( I, I ) + WILK1*CABS1( H( I, I-1 ) )
+                     W( I-1 ) = W( I )
+   30             CONTINUE
+               ELSE
+*
+*                 ==== Got NS/2 or fewer shifts? Use ZLAHQR
+*                 .    on a trailing principal submatrix to
+*                 .    get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+*                 .    there is enough space below the subdiagonal
+*                 .    to fit an NS-by-NS scratch array.) ====
+*
+                  IF( KBOT-KS+1.LE.NS / 2 ) THEN
+                     KS = KBOT - NS + 1
+                     KT = N - NS + 1
+                     CALL ZLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+     $                            H( KT, 1 ), LDH )
+                     CALL ZLAHQR( .false., .false., NS, 1, NS,
+     $                            H( KT, 1 ), LDH, W( KS ), 1, 1, ZDUM,
+     $                            1, INF )
+                     KS = KS + INF
+*
+*                    ==== In case of a rare QR failure use
+*                    .    eigenvalues of the trailing 2-by-2
+*                    .    principal submatrix.  Scale to avoid
+*                    .    overflows, underflows and subnormals.
+*                    .    (The scale factor S can not be zero,
+*                    .    because H(KBOT,KBOT-1) is nonzero.) ====
+*
+                     IF( KS.GE.KBOT ) THEN
+                        S = CABS1( H( KBOT-1, KBOT-1 ) ) +
+     $                      CABS1( H( KBOT, KBOT-1 ) ) +
+     $                      CABS1( H( KBOT-1, KBOT ) ) +
+     $                      CABS1( H( KBOT, KBOT ) )
+                        AA = H( KBOT-1, KBOT-1 ) / S
+                        CC = H( KBOT, KBOT-1 ) / S
+                        BB = H( KBOT-1, KBOT ) / S
+                        DD = H( KBOT, KBOT ) / S
+                        TR2 = ( AA+DD ) / TWO
+                        DET = ( AA-TR2 )*( DD-TR2 ) - BB*CC
+                        RTDISC = SQRT( -DET )
+                        W( KBOT-1 ) = ( TR2+RTDISC )*S
+                        W( KBOT ) = ( TR2-RTDISC )*S
+*
+                        KS = KBOT - 1
+                     END IF
+                  END IF
+*
+                  IF( KBOT-KS+1.GT.NS ) THEN
+*
+*                    ==== Sort the shifts (Helps a little) ====
+*
+                     SORTED = .false.
+                     DO 50 K = KBOT, KS + 1, -1
+                        IF( SORTED )
+     $                     GO TO 60
+                        SORTED = .true.
+                        DO 40 I = KS, K - 1
+                           IF( CABS1( W( I ) ).LT.CABS1( W( I+1 ) ) )
+     $                          THEN
+                              SORTED = .false.
+                              SWAP = W( I )
+                              W( I ) = W( I+1 )
+                              W( I+1 ) = SWAP
+                           END IF
+   40                   CONTINUE
+   50                CONTINUE
+   60                CONTINUE
+                  END IF
+               END IF
+*
+*              ==== If there are only two shifts, then use
+*              .    only one.  ====
+*
+               IF( KBOT-KS+1.EQ.2 ) THEN
+                  IF( CABS1( W( KBOT )-H( KBOT, KBOT ) ).LT.
+     $                CABS1( W( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+                     W( KBOT-1 ) = W( KBOT )
+                  ELSE
+                     W( KBOT ) = W( KBOT-1 )
+                  END IF
+               END IF
+*
+*              ==== Use up to NS of the the smallest magnatiude
+*              .    shifts.  If there aren't NS shifts available,
+*              .    then use them all, possibly dropping one to
+*              .    make the number of shifts even. ====
+*
+               NS = MIN( NS, KBOT-KS+1 )
+               NS = NS - MOD( NS, 2 )
+               KS = KBOT - NS + 1
+*
+*              ==== Small-bulge multi-shift QR sweep:
+*              .    split workspace under the subdiagonal into
+*              .    - a KDU-by-KDU work array U in the lower
+*              .      left-hand-corner,
+*              .    - a KDU-by-at-least-KDU-but-more-is-better
+*              .      (KDU-by-NHo) horizontal work array WH along
+*              .      the bottom edge,
+*              .    - and an at-least-KDU-but-more-is-better-by-KDU
+*              .      (NVE-by-KDU) vertical work WV arrow along
+*              .      the left-hand-edge. ====
+*
+               KDU = 3*NS - 3
+               KU = N - KDU + 1
+               KWH = KDU + 1
+               NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+               KWV = KDU + 4
+               NVE = N - KDU - KWV + 1
+*
+*              ==== Small-bulge multi-shift QR sweep ====
+*
+               CALL ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+     $                      W( KS ), H, LDH, ILOZ, IHIZ, Z, LDZ, WORK,
+     $                      3, H( KU, 1 ), LDH, NVE, H( KWV, 1 ), LDH,
+     $                      NHO, H( KU, KWH ), LDH )
+            END IF
+*
+*           ==== Note progress (or the lack of it). ====
+*
+            IF( LD.GT.0 ) THEN
+               NDFL = 1
+            ELSE
+               NDFL = NDFL + 1
+            END IF
+*
+*           ==== End of main loop ====
+   70    CONTINUE
+*
+*        ==== Iteration limit exceeded.  Set INFO to show where
+*        .    the problem occurred and exit. ====
+*
+         INFO = KBOT
+   80    CONTINUE
+      END IF
+*
+*     ==== Return the optimal value of LWORK. ====
+*
+      WORK( 1 ) = DCMPLX( LWKOPT, 0 )
+*
+*     ==== End of ZLAQR4 ====
+*
+      END
diff --git a/src/lib/lapack/zlaqr5.f b/src/lib/lapack/zlaqr5.f
new file mode 100644
index 00000000..fa8de7bb
--- /dev/null
+++ b/src/lib/lapack/zlaqr5.f
@@ -0,0 +1,809 @@
+      SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
+     $                   H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV,
+     $                   WV, LDWV, NH, WH, LDWH )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+     $                   LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+      LOGICAL            WANTT, WANTZ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ),
+     $                   WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * )
+*     ..
+*
+*     This auxiliary subroutine called by ZLAQR0 performs a
+*     single small-bulge multi-shift QR sweep.
+*
+*      WANTT  (input) logical scalar
+*             WANTT = .true. if the triangular Schur factor
+*             is being computed.  WANTT is set to .false. otherwise.
+*
+*      WANTZ  (input) logical scalar
+*             WANTZ = .true. if the unitary Schur factor is being
+*             computed.  WANTZ is set to .false. otherwise.
+*
+*      KACC22 (input) integer with value 0, 1, or 2.
+*             Specifies the computation mode of far-from-diagonal
+*             orthogonal updates.
+*        = 0: ZLAQR5 does not accumulate reflections and does not
+*             use matrix-matrix multiply to update far-from-diagonal
+*             matrix entries.
+*        = 1: ZLAQR5 accumulates reflections and uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries.
+*        = 2: ZLAQR5 accumulates reflections, uses matrix-matrix
+*             multiply to update the far-from-diagonal matrix entries,
+*             and takes advantage of 2-by-2 block structure during
+*             matrix multiplies.
+*
+*      N      (input) integer scalar
+*             N is the order of the Hessenberg matrix H upon which this
+*             subroutine operates.
+*
+*      KTOP   (input) integer scalar
+*      KBOT   (input) integer scalar
+*             These are the first and last rows and columns of an
+*             isolated diagonal block upon which the QR sweep is to be
+*             applied. It is assumed without a check that
+*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0
+*             and
+*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.
+*
+*      NSHFTS (input) integer scalar
+*             NSHFTS gives the number of simultaneous shifts.  NSHFTS
+*             must be positive and even.
+*
+*      S      (input) COMPLEX*16 array of size (NSHFTS)
+*             S contains the shifts of origin that define the multi-
+*             shift QR sweep.
+*
+*      H      (input/output) COMPLEX*16 array of size (LDH,N)
+*             On input H contains a Hessenberg matrix.  On output a
+*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+*             to the isolated diagonal block in rows and columns KTOP
+*             through KBOT.
+*
+*      LDH    (input) integer scalar
+*             LDH is the leading dimension of H just as declared in the
+*             calling procedure.  LDH.GE.MAX(1,N).
+*
+*      ILOZ   (input) INTEGER
+*      IHIZ   (input) INTEGER
+*             Specify the rows of Z to which transformations must be
+*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+*      Z      (input/output) COMPLEX*16 array of size (LDZ,IHI)
+*             If WANTZ = .TRUE., then the QR Sweep unitary
+*             similarity transformation is accumulated into
+*             Z(ILOZ:IHIZ,ILO:IHI) from the right.
+*             If WANTZ = .FALSE., then Z is unreferenced.
+*
+*      LDZ    (input) integer scalar
+*             LDA is the leading dimension of Z just as declared in
+*             the calling procedure. LDZ.GE.N.
+*
+*      V      (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)
+*
+*      LDV    (input) integer scalar
+*             LDV is the leading dimension of V as declared in the
+*             calling procedure.  LDV.GE.3.
+*
+*      U      (workspace) COMPLEX*16 array of size
+*             (LDU,3*NSHFTS-3)
+*
+*      LDU    (input) integer scalar
+*             LDU is the leading dimension of U just as declared in the
+*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.
+*
+*      NH     (input) integer scalar
+*             NH is the number of columns in array WH available for
+*             workspace. NH.GE.1.
+*
+*      WH     (workspace) COMPLEX*16 array of size (LDWH,NH)
+*
+*      LDWH   (input) integer scalar
+*             Leading dimension of WH just as declared in the
+*             calling procedure.  LDWH.GE.3*NSHFTS-3.
+*
+*      NV     (input) integer scalar
+*             NV is the number of rows in WV agailable for workspace.
+*             NV.GE.1.
+*
+*      WV     (workspace) COMPLEX*16 array of size
+*             (LDWV,3*NSHFTS-3)
+*
+*      LDWV   (input) integer scalar
+*             LDWV is the leading dimension of WV as declared in the
+*             in the calling subroutine.  LDWV.GE.NV.
+*
+*     ================================================================
+*     Based on contributions by
+*        Karen Braman and Ralph Byers, Department of Mathematics,
+*        University of Kansas, USA
+*
+*      ============================================================
+*      Reference:
+*
+*      K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+*      Algorithm Part I: Maintaining Well Focused Shifts, and
+*      Level 3 Performance, SIAM Journal of Matrix Analysis,
+*      volume 23, pages 929--947, 2002.
+*
+*      ============================================================
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0d0, 0.0d0 ),
+     $                   ONE = ( 1.0d0, 0.0d0 ) )
+      DOUBLE PRECISION   RZERO, RONE
+      PARAMETER          ( RZERO = 0.0d0, RONE = 1.0d0 )
+*     ..
+*     .. Local Scalars ..
+      COMPLEX*16         ALPHA, BETA, CDUM, REFSUM
+      DOUBLE PRECISION   H11, H12, H21, H22, SAFMAX, SAFMIN, SCL,
+     $                   SMLNUM, TST1, TST2, ULP
+      INTEGER            I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+     $                   JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+     $                   M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+     $                   NS, NU
+      LOGICAL            ACCUM, BLK22, BMP22
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+*
+      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, MAX, MIN, MOD
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         VT( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, ZGEMM, ZLACPY, ZLAQR1, ZLARFG, ZLASET,
+     $                   ZTRMM
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     ==== If there are no shifts, then there is nothing to do. ====
+*
+      IF( NSHFTS.LT.2 )
+     $   RETURN
+*
+*     ==== If the active block is empty or 1-by-1, then there
+*     .    is nothing to do. ====
+*
+      IF( KTOP.GE.KBOT )
+     $   RETURN
+*
+*     ==== NSHFTS is supposed to be even, but if is odd,
+*     .    then simply reduce it by one.  ====
+*
+      NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+*     ==== Machine constants for deflation ====
+*
+      SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+      SAFMAX = RONE / SAFMIN
+      CALL DLABAD( SAFMIN, SAFMAX )
+      ULP = DLAMCH( 'PRECISION' )
+      SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+*     ==== Use accumulated reflections to update far-from-diagonal
+*     .    entries ? ====
+*
+      ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+*
+*     ==== If so, exploit the 2-by-2 block structure? ====
+*
+      BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+*     ==== clear trash ====
+*
+      IF( KTOP+2.LE.KBOT )
+     $   H( KTOP+2, KTOP ) = ZERO
+*
+*     ==== NBMPS = number of 2-shift bulges in the chain ====
+*
+      NBMPS = NS / 2
+*
+*     ==== KDU = width of slab ====
+*
+      KDU = 6*NBMPS - 3
+*
+*     ==== Create and chase chains of NBMPS bulges ====
+*
+      DO 210 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
+         NDCOL = INCOL + KDU
+         IF( ACCUM )
+     $      CALL ZLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
+*
+*        ==== Near-the-diagonal bulge chase.  The following loop
+*        .    performs the near-the-diagonal part of a small bulge
+*        .    multi-shift QR sweep.  Each 6*NBMPS-2 column diagonal
+*        .    chunk extends from column INCOL to column NDCOL
+*        .    (including both column INCOL and column NDCOL). The
+*        .    following loop chases a 3*NBMPS column long chain of
+*        .    NBMPS bulges 3*NBMPS-2 columns to the right.  (INCOL
+*        .    may be less than KTOP and and NDCOL may be greater than
+*        .    KBOT indicating phantom columns from which to chase
+*        .    bulges before they are actually introduced or to which
+*        .    to chase bulges beyond column KBOT.)  ====
+*
+         DO 140 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
+*
+*           ==== Bulges number MTOP to MBOT are active double implicit
+*           .    shift bulges.  There may or may not also be small
+*           .    2-by-2 bulge, if there is room.  The inactive bulges
+*           .    (if any) must wait until the active bulges have moved
+*           .    down the diagonal to make room.  The phantom matrix
+*           .    paradigm described above helps keep track.  ====
+*
+            MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
+            MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
+            M22 = MBOT + 1
+            BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
+     $              ( KBOT-2 )
+*
+*           ==== Generate reflections to chase the chain right
+*           .    one column.  (The minimum value of K is KTOP-1.) ====
+*
+            DO 10 M = MTOP, MBOT
+               K = KRCOL + 3*( M-1 )
+               IF( K.EQ.KTOP-1 ) THEN
+                  CALL ZLAQR1( 3, H( KTOP, KTOP ), LDH, S( 2*M-1 ),
+     $                         S( 2*M ), V( 1, M ) )
+                  ALPHA = V( 1, M )
+                  CALL ZLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M ) = H( K+2, K )
+                  V( 3, M ) = H( K+3, K )
+                  CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
+*
+*                 ==== A Bulge may collapse because of vigilant
+*                 .    deflation or destructive underflow.  (The
+*                 .    initial bulge is always collapsed.) Use
+*                 .    the two-small-subdiagonals trick to try
+*                 .    to get it started again. If V(2,M).NE.0 and
+*                 .    V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
+*                 .    this bulge is collapsing into a zero
+*                 .    subdiagonal.  It will be restarted next
+*                 .    trip through the loop.)
+*
+                  IF( V( 1, M ).NE.ZERO .AND.
+     $                ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
+     $                K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
+     $                 THEN
+*
+*                    ==== Typical case: not collapsed (yet). ====
+*
+                     H( K+1, K ) = BETA
+                     H( K+2, K ) = ZERO
+                     H( K+3, K ) = ZERO
+                  ELSE
+*
+*                    ==== Atypical case: collapsed.  Attempt to
+*                    .    reintroduce ignoring H(K+1,K).  If the
+*                    .    fill resulting from the new reflector
+*                    .    is too large, then abandon it.
+*                    .    Otherwise, use the new one. ====
+*
+                     CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ),
+     $                            S( 2*M ), VT )
+                     SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) +
+     $                     CABS1( VT( 3 ) )
+                     IF( SCL.NE.RZERO ) THEN
+                        VT( 1 ) = VT( 1 ) / SCL
+                        VT( 2 ) = VT( 2 ) / SCL
+                        VT( 3 ) = VT( 3 ) / SCL
+                     END IF
+*
+*                    ==== The following is the traditional and
+*                    .    conservative two-small-subdiagonals
+*                    .    test.  ====
+*                    .
+                     IF( CABS1( H( K+1, K ) )*
+     $                   ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP*
+     $                   CABS1( VT( 1 ) )*( CABS1( H( K,
+     $                   K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2,
+     $                   K+2 ) ) ) ) THEN
+*
+*                       ==== Starting a new bulge here would
+*                       .    create non-negligible fill.   If
+*                       .    the old reflector is diagonal (only
+*                       .    possible with underflows), then
+*                       .    change it to I.  Otherwise, use
+*                       .    it with trepidation. ====
+*
+                        IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
+     $                       THEN
+                           V( 1, M ) = ZERO
+                        ELSE
+                           H( K+1, K ) = BETA
+                           H( K+2, K ) = ZERO
+                           H( K+3, K ) = ZERO
+                        END IF
+                     ELSE
+*
+*                       ==== Stating a new bulge here would
+*                       .    create only negligible fill.
+*                       .    Replace the old reflector with
+*                       .    the new one. ====
+*
+                        ALPHA = VT( 1 )
+                        CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
+                        REFSUM = H( K+1, K ) +
+     $                           H( K+2, K )*DCONJG( VT( 2 ) ) +
+     $                           H( K+3, K )*DCONJG( VT( 3 ) )
+                        H( K+1, K ) = H( K+1, K ) -
+     $                                DCONJG( VT( 1 ) )*REFSUM
+                        H( K+2, K ) = ZERO
+                        H( K+3, K ) = ZERO
+                        V( 1, M ) = VT( 1 )
+                        V( 2, M ) = VT( 2 )
+                        V( 3, M ) = VT( 3 )
+                     END IF
+                  END IF
+               END IF
+   10       CONTINUE
+*
+*           ==== Generate a 2-by-2 reflection, if needed. ====
+*
+            K = KRCOL + 3*( M22-1 )
+            IF( BMP22 ) THEN
+               IF( K.EQ.KTOP-1 ) THEN
+                  CALL ZLAQR1( 2, H( K+1, K+1 ), LDH, S( 2*M22-1 ),
+     $                         S( 2*M22 ), V( 1, M22 ) )
+                  BETA = V( 1, M22 )
+                  CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+               ELSE
+                  BETA = H( K+1, K )
+                  V( 2, M22 ) = H( K+2, K )
+                  CALL ZLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+                  H( K+1, K ) = BETA
+                  H( K+2, K ) = ZERO
+               END IF
+            ELSE
+*
+*              ==== Initialize V(1,M22) here to avoid possible undefined
+*              .    variable problems later. ====
+*
+               V( 1, M22 ) = ZERO
+            END IF
+*
+*           ==== Multiply H by reflections from the left ====
+*
+            IF( ACCUM ) THEN
+               JBOT = MIN( NDCOL, KBOT )
+            ELSE IF( WANTT ) THEN
+               JBOT = N
+            ELSE
+               JBOT = KBOT
+            END IF
+            DO 30 J = MAX( KTOP, KRCOL ), JBOT
+               MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
+               DO 20 M = MTOP, MEND
+                  K = KRCOL + 3*( M-1 )
+                  REFSUM = DCONJG( V( 1, M ) )*
+     $                     ( H( K+1, J )+DCONJG( V( 2, M ) )*
+     $                     H( K+2, J )+DCONJG( V( 3, M ) )*H( K+3, J ) )
+                  H( K+1, J ) = H( K+1, J ) - REFSUM
+                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
+                  H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
+   20          CONTINUE
+   30       CONTINUE
+            IF( BMP22 ) THEN
+               K = KRCOL + 3*( M22-1 )
+               DO 40 J = MAX( K+1, KTOP ), JBOT
+                  REFSUM = DCONJG( V( 1, M22 ) )*
+     $                     ( H( K+1, J )+DCONJG( V( 2, M22 ) )*
+     $                     H( K+2, J ) )
+                  H( K+1, J ) = H( K+1, J ) - REFSUM
+                  H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
+   40          CONTINUE
+            END IF
+*
+*           ==== Multiply H by reflections from the right.
+*           .    Delay filling in the last row until the
+*           .    vigilant deflation check is complete. ====
+*
+            IF( ACCUM ) THEN
+               JTOP = MAX( KTOP, INCOL )
+            ELSE IF( WANTT ) THEN
+               JTOP = 1
+            ELSE
+               JTOP = KTOP
+            END IF
+            DO 80 M = MTOP, MBOT
+               IF( V( 1, M ).NE.ZERO ) THEN
+                  K = KRCOL + 3*( M-1 )
+                  DO 50 J = JTOP, MIN( KBOT, K+3 )
+                     REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
+     $                        H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
+                     H( J, K+1 ) = H( J, K+1 ) - REFSUM
+                     H( J, K+2 ) = H( J, K+2 ) -
+     $                             REFSUM*DCONJG( V( 2, M ) )
+                     H( J, K+3 ) = H( J, K+3 ) -
+     $                             REFSUM*DCONJG( V( 3, M ) )
+   50             CONTINUE
+*
+                  IF( ACCUM ) THEN
+*
+*                    ==== Accumulate U. (If necessary, update Z later
+*                    .    with with an efficient matrix-matrix
+*                    .    multiply.) ====
+*
+                     KMS = K - INCOL
+                     DO 60 J = MAX( 1, KTOP-INCOL ), KDU
+                        REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
+     $                           U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
+                        U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+                        U( J, KMS+2 ) = U( J, KMS+2 ) -
+     $                                  REFSUM*DCONJG( V( 2, M ) )
+                        U( J, KMS+3 ) = U( J, KMS+3 ) -
+     $                                  REFSUM*DCONJG( V( 3, M ) )
+   60                CONTINUE
+                  ELSE IF( WANTZ ) THEN
+*
+*                    ==== U is not accumulated, so update Z
+*                    .    now by multiplying by reflections
+*                    .    from the right. ====
+*
+                     DO 70 J = ILOZ, IHIZ
+                        REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
+     $                           Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
+                        Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+                        Z( J, K+2 ) = Z( J, K+2 ) -
+     $                                REFSUM*DCONJG( V( 2, M ) )
+                        Z( J, K+3 ) = Z( J, K+3 ) -
+     $                                REFSUM*DCONJG( V( 3, M ) )
+   70                CONTINUE
+                  END IF
+               END IF
+   80       CONTINUE
+*
+*           ==== Special case: 2-by-2 reflection (if needed) ====
+*
+            K = KRCOL + 3*( M22-1 )
+            IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
+               DO 90 J = JTOP, MIN( KBOT, K+3 )
+                  REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
+     $                     H( J, K+2 ) )
+                  H( J, K+1 ) = H( J, K+1 ) - REFSUM
+                  H( J, K+2 ) = H( J, K+2 ) -
+     $                          REFSUM*DCONJG( V( 2, M22 ) )
+   90          CONTINUE
+*
+               IF( ACCUM ) THEN
+                  KMS = K - INCOL
+                  DO 100 J = MAX( 1, KTOP-INCOL ), KDU
+                     REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
+     $                        U( J, KMS+2 ) )
+                     U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+                     U( J, KMS+2 ) = U( J, KMS+2 ) -
+     $                               REFSUM*DCONJG( V( 2, M22 ) )
+  100             CONTINUE
+               ELSE IF( WANTZ ) THEN
+                  DO 110 J = ILOZ, IHIZ
+                     REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
+     $                        Z( J, K+2 ) )
+                     Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+                     Z( J, K+2 ) = Z( J, K+2 ) -
+     $                             REFSUM*DCONJG( V( 2, M22 ) )
+  110             CONTINUE
+               END IF
+            END IF
+*
+*           ==== Vigilant deflation check ====
+*
+            MSTART = MTOP
+            IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
+     $         MSTART = MSTART + 1
+            MEND = MBOT
+            IF( BMP22 )
+     $         MEND = MEND + 1
+            IF( KRCOL.EQ.KBOT-2 )
+     $         MEND = MEND + 1
+            DO 120 M = MSTART, MEND
+               K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
+*
+*              ==== The following convergence test requires that
+*              .    the tradition small-compared-to-nearby-diagonals
+*              .    criterion and the Ahues & Tisseur (LAWN 122, 1997)
+*              .    criteria both be satisfied.  The latter improves
+*              .    accuracy in some examples. Falling back on an
+*              .    alternate convergence criterion when TST1 or TST2
+*              .    is zero (as done here) is traditional but probably
+*              .    unnecessary. ====
+*
+               IF( H( K+1, K ).NE.ZERO ) THEN
+                  TST1 = CABS1( H( K, K ) ) + CABS1( H( K+1, K+1 ) )
+                  IF( TST1.EQ.RZERO ) THEN
+                     IF( K.GE.KTOP+1 )
+     $                  TST1 = TST1 + CABS1( H( K, K-1 ) )
+                     IF( K.GE.KTOP+2 )
+     $                  TST1 = TST1 + CABS1( H( K, K-2 ) )
+                     IF( K.GE.KTOP+3 )
+     $                  TST1 = TST1 + CABS1( H( K, K-3 ) )
+                     IF( K.LE.KBOT-2 )
+     $                  TST1 = TST1 + CABS1( H( K+2, K+1 ) )
+                     IF( K.LE.KBOT-3 )
+     $                  TST1 = TST1 + CABS1( H( K+3, K+1 ) )
+                     IF( K.LE.KBOT-4 )
+     $                  TST1 = TST1 + CABS1( H( K+4, K+1 ) )
+                  END IF
+                  IF( CABS1( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
+     $                 THEN
+                     H12 = MAX( CABS1( H( K+1, K ) ),
+     $                     CABS1( H( K, K+1 ) ) )
+                     H21 = MIN( CABS1( H( K+1, K ) ),
+     $                     CABS1( H( K, K+1 ) ) )
+                     H11 = MAX( CABS1( H( K+1, K+1 ) ),
+     $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
+                     H22 = MIN( CABS1( H( K+1, K+1 ) ),
+     $                     CABS1( H( K, K )-H( K+1, K+1 ) ) )
+                     SCL = H11 + H12
+                     TST2 = H22*( H11 / SCL )
+*
+                     IF( TST2.EQ.RZERO .OR. H21*( H12 / SCL ).LE.
+     $                   MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
+                  END IF
+               END IF
+  120       CONTINUE
+*
+*           ==== Fill in the last row of each bulge. ====
+*
+            MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
+            DO 130 M = MTOP, MEND
+               K = KRCOL + 3*( M-1 )
+               REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
+               H( K+4, K+1 ) = -REFSUM
+               H( K+4, K+2 ) = -REFSUM*DCONJG( V( 2, M ) )
+               H( K+4, K+3 ) = H( K+4, K+3 ) -
+     $                         REFSUM*DCONJG( V( 3, M ) )
+  130       CONTINUE
+*
+*           ==== End of near-the-diagonal bulge chase. ====
+*
+  140    CONTINUE
+*
+*        ==== Use U (if accumulated) to update far-from-diagonal
+*        .    entries in H.  If required, use U to update Z as
+*        .    well. ====
+*
+         IF( ACCUM ) THEN
+            IF( WANTT ) THEN
+               JTOP = 1
+               JBOT = N
+            ELSE
+               JTOP = KTOP
+               JBOT = KBOT
+            END IF
+            IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+     $          ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
+*
+*              ==== Updates not exploiting the 2-by-2 block
+*              .    structure of U.  K1 and NU keep track of
+*              .    the location and size of U in the special
+*              .    cases of introducing bulges and chasing
+*              .    bulges off the bottom.  In these special
+*              .    cases and in case the number of shifts
+*              .    is NS = 2, there is no 2-by-2 block
+*              .    structure to exploit.  ====
+*
+               K1 = MAX( 1, KTOP-INCOL )
+               NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
+*
+*              ==== Horizontal Multiply ====
+*
+               DO 150 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+                  JLEN = MIN( NH, JBOT-JCOL+1 )
+                  CALL ZGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+     $                        LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+     $                        LDWH )
+                  CALL ZLACPY( 'ALL', NU, JLEN, WH, LDWH,
+     $                         H( INCOL+K1, JCOL ), LDH )
+  150          CONTINUE
+*
+*              ==== Vertical multiply ====
+*
+               DO 160 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
+                  JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
+                  CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                        H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+     $                        LDU, ZERO, WV, LDWV )
+                  CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
+     $                         H( JROW, INCOL+K1 ), LDH )
+  160          CONTINUE
+*
+*              ==== Z multiply (also vertical) ====
+*
+               IF( WANTZ ) THEN
+                  DO 170 JROW = ILOZ, IHIZ, NV
+                     JLEN = MIN( NV, IHIZ-JROW+1 )
+                     CALL ZGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+     $                           Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+     $                           LDU, ZERO, WV, LDWV )
+                     CALL ZLACPY( 'ALL', JLEN, NU, WV, LDWV,
+     $                            Z( JROW, INCOL+K1 ), LDZ )
+  170             CONTINUE
+               END IF
+            ELSE
+*
+*              ==== Updates exploiting U's 2-by-2 block structure.
+*              .    (I2, I4, J2, J4 are the last rows and columns
+*              .    of the blocks.) ====
+*
+               I2 = ( KDU+1 ) / 2
+               I4 = KDU
+               J2 = I4 - I2
+               J4 = KDU
+*
+*              ==== KZS and KNZ deal with the band of zeros
+*              .    along the diagonal of one of the triangular
+*              .    blocks. ====
+*
+               KZS = ( J4-J2 ) - ( NS+1 )
+               KNZ = NS + 1
+*
+*              ==== Horizontal multiply ====
+*
+               DO 180 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+                  JLEN = MIN( NH, JBOT-JCOL+1 )
+*
+*                 ==== Copy bottom of H to top+KZS of scratch ====
+*                  (The first KZS rows get multiplied by zero.) ====
+*
+                  CALL ZLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+     $                         LDH, WH( KZS+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL ZLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+                  CALL ZTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+     $                        LDWH )
+*
+*                 ==== Multiply top of H by U11' ====
+*
+                  CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+     $                        H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+*                 ==== Copy top of H bottom of WH ====
+*
+                  CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+     $                         WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U21' ====
+*
+                  CALL ZTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+     $                        U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL ZGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+     $                        U( J2+1, I2+1 ), LDU,
+     $                        H( INCOL+1+J2, JCOL ), LDH, ONE,
+     $                        WH( I2+1, 1 ), LDWH )
+*
+*                 ==== Copy it back ====
+*
+                  CALL ZLACPY( 'ALL', KDU, JLEN, WH, LDWH,
+     $                         H( INCOL+1, JCOL ), LDH )
+  180          CONTINUE
+*
+*              ==== Vertical multiply ====
+*
+               DO 190 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
+                  JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
+*
+*                 ==== Copy right of H to scratch (the first KZS
+*                 .    columns get multiplied by zero) ====
+*
+                  CALL ZLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+     $                         LDH, WV( 1, 1+KZS ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+                  CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                        U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                        LDWV )
+*
+*                 ==== Multiply by U11 ====
+*
+                  CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                        H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
+     $                        LDWV )
+*
+*                 ==== Copy left of H to right of scratch ====
+*
+                  CALL ZLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+     $                         WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U21 ====
+*
+                  CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                        U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+*                 ==== Multiply by U22 ====
+*
+                  CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                        H( JROW, INCOL+1+J2 ), LDH,
+     $                        U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
+     $                        LDWV )
+*
+*                 ==== Copy it back ====
+*
+                  CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                         H( JROW, INCOL+1 ), LDH )
+  190          CONTINUE
+*
+*              ==== Multiply Z (also vertical) ====
+*
+               IF( WANTZ ) THEN
+                  DO 200 JROW = ILOZ, IHIZ, NV
+                     JLEN = MIN( NV, IHIZ-JROW+1 )
+*
+*                    ==== Copy right of Z to left of scratch (first
+*                    .     KZS columns get multiplied by zero) ====
+*
+                     CALL ZLACPY( 'ALL', JLEN, KNZ,
+     $                            Z( JROW, INCOL+1+J2 ), LDZ,
+     $                            WV( 1, 1+KZS ), LDWV )
+*
+*                    ==== Multiply by U12 ====
+*
+                     CALL ZLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+     $                            LDWV )
+                     CALL ZTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+     $                           U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U11 ====
+*
+                     CALL ZGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+     $                           Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
+     $                           WV, LDWV )
+*
+*                    ==== Copy left of Z to right of scratch ====
+*
+                     CALL ZLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+     $                            LDZ, WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Multiply by U21 ====
+*
+                     CALL ZTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+     $                           U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+     $                           LDWV )
+*
+*                    ==== Multiply by U22 ====
+*
+                     CALL ZGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+     $                           Z( JROW, INCOL+1+J2 ), LDZ,
+     $                           U( J2+1, I2+1 ), LDU, ONE,
+     $                           WV( 1, 1+I2 ), LDWV )
+*
+*                    ==== Copy the result back to Z ====
+*
+                     CALL ZLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+     $                            Z( JROW, INCOL+1 ), LDZ )
+  200             CONTINUE
+               END IF
+            END IF
+         END IF
+  210 CONTINUE
+*
+*     ==== End of ZLAQR5 ====
+*
+      END
diff --git a/src/lib/lapack/zlarf.f b/src/lib/lapack/zlarf.f
new file mode 100644
index 00000000..d5233c8c
--- /dev/null
+++ b/src/lib/lapack/zlarf.f
@@ -0,0 +1,120 @@
+      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, LDC, M, N
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARF applies a complex elementary reflector H to a complex M-by-N
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a complex scalar and v is a complex vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
+*  tau.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) COMPLEX*16 array, dimension
+*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+*          The vector v in the representation of H. V is not used if
+*          TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) COMPLEX*16
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZGERC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C' * v
+*
+            CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V,
+     $                  INCV, ZERO, WORK, 1 )
+*
+*           C := C - v * w'
+*
+            CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+         END IF
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w := C * v
+*
+            CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+     $                  ZERO, WORK, 1 )
+*
+*           C := C - w * v'
+*
+            CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLARF
+*
+      END
diff --git a/src/lib/lapack/zlarfb.f b/src/lib/lapack/zlarfb.f
new file mode 100644
index 00000000..af93ea58
--- /dev/null
+++ b/src/lib/lapack/zlarfb.f
@@ -0,0 +1,608 @@
+      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+     $                   T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFB applies a complex block reflector H or its transpose H' to a
+*  complex M-by-N matrix C, from either the left or the right.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'C': apply H' (Conjugate transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  V       (input) COMPLEX*16 array, dimension
+*                                (LDV,K) if STOREV = 'C'
+*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
+*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+*          if STOREV = 'R', LDV >= K.
+*
+*  T       (input) COMPLEX*16 array, dimension (LDT,K)
+*          The triangular K-by-K matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZCOPY, ZGEMM, ZLACGV, ZTRMM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'C'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( STOREV, 'C' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1 )    (first K rows)
+*                     ( V2 )
+*           where  V1  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C1'
+*
+               DO 10 J = 1, K
+                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+   10          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+     $                        K, M-K, ONE, C( K+1, 1 ), LDC,
+     $                        V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2 * W'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        M-K, N, K, -ONE, V( K+1, 1 ), LDV, WORK,
+     $                        LDWORK, ONE, C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 30 J = 1, K
+                  DO 20 I = 1, N
+                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
+   20             CONTINUE
+   30          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C1
+*
+               DO 40 J = 1, K
+                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40          CONTINUE
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+     $                        ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        N-K, K, -ONE, WORK, LDWORK, V( K+1, 1 ),
+     $                        LDV, ONE, C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 60 J = 1, K
+                  DO 50 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+   50             CONTINUE
+   60          CONTINUE
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1 )
+*                     ( V2 )    (last K rows)
+*           where  V2  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
+*
+*              W := C2'
+*
+               DO 70 J = 1, K
+                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+   70          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', N,
+     $                        K, M-K, ONE, C, LDC, V, LDV, ONE, WORK,
+     $                        LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1 * W'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        M-K, N, K, -ONE, V, LDV, WORK, LDWORK,
+     $                        ONE, C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V( M-K+1, 1 ), LDV, WORK,
+     $                     LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 90 J = 1, K
+                  DO 80 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) -
+     $                               DCONJG( WORK( I, J ) )
+   80             CONTINUE
+   90          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
+*
+*              W := C2
+*
+               DO 100 J = 1, K
+                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  100          CONTINUE
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, K, N-K,
+     $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V'
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        N-K, K, -ONE, WORK, LDWORK, V, LDV, ONE,
+     $                        C, LDC )
+               END IF
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V( N-K+1, 1 ), LDV, WORK,
+     $                     LDWORK )
+*
+*              C2 := C2 - W
+*
+               DO 120 J = 1, K
+                  DO 110 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  110             CONTINUE
+  120          CONTINUE
+            END IF
+         END IF
+*
+      ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+         IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+*           Let  V =  ( V1  V2 )    (V1: first K columns)
+*           where  V1  is unit upper triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C1'
+*
+               DO 130 J = 1, K
+                  CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+  130          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V, LDV, WORK, LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C2'*V2'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', N, K, M-K, ONE,
+     $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+     $                        WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C2 := C2 - V2' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', M-K, N, K, -ONE,
+     $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+     $                        C( K+1, 1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W'
+*
+               DO 150 J = 1, K
+                  DO 140 I = 1, N
+                     C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
+  140             CONTINUE
+  150          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C1
+*
+               DO 160 J = 1, K
+                  CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+  160          CONTINUE
+*
+*              W := W * V1'
+*
+               CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V, LDV, WORK, LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C2 * V2'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        K, N-K, ONE, C( 1, K+1 ), LDC,
+     $                        V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C2 := C2 - W * V2
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+     $                        C( 1, K+1 ), LDC )
+               END IF
+*
+*              W := W * V1
+*
+               CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+     $                     K, ONE, V, LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 180 J = 1, K
+                  DO 170 I = 1, M
+                     C( I, J ) = C( I, J ) - WORK( I, J )
+  170             CONTINUE
+  180          CONTINUE
+*
+            END IF
+*
+         ELSE
+*
+*           Let  V =  ( V1  V2 )    (V2: last K columns)
+*           where  V2  is unit lower triangular.
+*
+            IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*              Form  H * C  or  H' * C  where  C = ( C1 )
+*                                                  ( C2 )
+*
+*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
+*
+*              W := C2'
+*
+               DO 190 J = 1, K
+                  CALL ZCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+                  CALL ZLACGV( N, WORK( 1, J ), 1 )
+  190          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', N, K, ONE, V( 1, M-K+1 ), LDV, WORK,
+     $                     LDWORK )
+               IF( M.GT.K ) THEN
+*
+*                 W := W + C1'*V1'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', N, K, M-K, ONE, C,
+     $                        LDC, V, LDV, ONE, WORK, LDWORK )
+               END IF
+*
+*              W := W * T'  or  W * T
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - V' * W'
+*
+               IF( M.GT.K ) THEN
+*
+*                 C1 := C1 - V1' * W'
+*
+                  CALL ZGEMM( 'Conjugate transpose',
+     $                        'Conjugate transpose', M-K, N, K, -ONE, V,
+     $                        LDV, WORK, LDWORK, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+     $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+*              C2 := C2 - W'
+*
+               DO 210 J = 1, K
+                  DO 200 I = 1, N
+                     C( M-K+J, I ) = C( M-K+J, I ) -
+     $                               DCONJG( WORK( I, J ) )
+  200             CONTINUE
+  210          CONTINUE
+*
+            ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*              Form  C * H  or  C * H'  where  C = ( C1  C2 )
+*
+*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
+*
+*              W := C2
+*
+               DO 220 J = 1, K
+                  CALL ZCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+  220          CONTINUE
+*
+*              W := W * V2'
+*
+               CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
+     $                     'Unit', M, K, ONE, V( 1, N-K+1 ), LDV, WORK,
+     $                     LDWORK )
+               IF( N.GT.K ) THEN
+*
+*                 W := W + C1 * V1'
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose', M,
+     $                        K, N-K, ONE, C, LDC, V, LDV, ONE, WORK,
+     $                        LDWORK )
+               END IF
+*
+*              W := W * T  or  W * T'
+*
+               CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+     $                     ONE, T, LDT, WORK, LDWORK )
+*
+*              C := C - W * V
+*
+               IF( N.GT.K ) THEN
+*
+*                 C1 := C1 - W * V1
+*
+                  CALL ZGEMM( 'No transpose', 'No transpose', M, N-K, K,
+     $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+               END IF
+*
+*              W := W * V2
+*
+               CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+     $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+*              C1 := C1 - W
+*
+               DO 240 J = 1, K
+                  DO 230 I = 1, M
+                     C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+  230             CONTINUE
+  240          CONTINUE
+*
+            END IF
+*
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFB
+*
+      END
diff --git a/src/lib/lapack/zlarfg.f b/src/lib/lapack/zlarfg.f
new file mode 100644
index 00000000..d024f928
--- /dev/null
+++ b/src/lib/lapack/zlarfg.f
@@ -0,0 +1,145 @@
+      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      COMPLEX*16         ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFG generates a complex elementary reflector H of order n, such
+*  that
+*
+*        H' * ( alpha ) = ( beta ),   H' * H = I.
+*             (   x   )   (   0  )
+*
+*  where alpha and beta are scalars, with beta real, and x is an
+*  (n-1)-element complex vector. H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( v )
+*
+*  where tau is a complex scalar and v is a complex (n-1)-element
+*  vector. Note that H is not hermitian.
+*
+*  If the elements of x are all zero and alpha is real, then tau = 0
+*  and H is taken to be the unit matrix.
+*
+*  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the elementary reflector.
+*
+*  ALPHA   (input/output) COMPLEX*16
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) COMPLEX*16 array, dimension
+*                         (1+(N-2)*abs(INCX))
+*          On entry, the vector x.
+*          On exit, it is overwritten with the vector v.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  TAU     (output) COMPLEX*16
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
+      COMPLEX*16         ZLADIV
+      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZDSCAL, ZSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DZNRM2( N-1, X, INCX )
+      ALPHR = DBLE( ALPHA )
+      ALPHI = DIMAG( ALPHA )
+*
+      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            KNT = 0
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL ZDSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHI = ALPHI*RSAFMN
+            ALPHR = ALPHR*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DZNRM2( N-1, X, INCX )
+            ALPHA = DCMPLX( ALPHR, ALPHI )
+            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+*
+*           If ALPHA is subnormal, it may lose relative accuracy
+*
+            ALPHA = BETA
+            DO 20 J = 1, KNT
+               ALPHA = ALPHA*SAFMIN
+   20       CONTINUE
+         ELSE
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+            ALPHA = BETA
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFG
+*
+      END
diff --git a/src/lib/lapack/zlarft.f b/src/lib/lapack/zlarft.f
new file mode 100644
index 00000000..412265e3
--- /dev/null
+++ b/src/lib/lapack/zlarft.f
@@ -0,0 +1,224 @@
+      SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFT forms the triangular factor T of a complex block reflector H
+*  of order n, which is defined as a product of k elementary reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) COMPLEX*16 array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) COMPLEX*16 array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
+*                   ( v1  1    )                     (     1 v2 v2 v2 )
+*                   ( v1 v2  1 )                     (        1 v3 v3 )
+*                   ( v1 v2 v3 )
+*                   ( v1 v2 v3 )
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
+*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
+*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
+*                   (     1 v3 )
+*                   (        1 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J
+      COMPLEX*16         VII
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZLACGV, ZTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( LSAME( DIRECT, 'F' ) ) THEN
+         DO 20 I = 1, K
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 10 J = 1, I
+                  T( J, I ) = ZERO
+   10          CONTINUE
+            ELSE
+*
+*              general case
+*
+               VII = V( I, I )
+               V( I, I ) = ONE
+               IF( LSAME( STOREV, 'C' ) ) THEN
+*
+*                 T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+                  CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1,
+     $                        -TAU( I ), V( I, 1 ), LDV, V( I, I ), 1,
+     $                        ZERO, T( 1, I ), 1 )
+               ELSE
+*
+*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+                  IF( I.LT.N )
+     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
+                  CALL ZGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+     $                        V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+     $                        T( 1, I ), 1 )
+                  IF( I.LT.N )
+     $               CALL ZLACGV( N-I, V( I, I+1 ), LDV )
+               END IF
+               V( I, I ) = VII
+*
+*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+               CALL ZTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+     $                     LDT, T( 1, I ), 1 )
+               T( I, I ) = TAU( I )
+            END IF
+   20    CONTINUE
+      ELSE
+         DO 40 I = K, 1, -1
+            IF( TAU( I ).EQ.ZERO ) THEN
+*
+*              H(i)  =  I
+*
+               DO 30 J = I, K
+                  T( J, I ) = ZERO
+   30          CONTINUE
+            ELSE
+*
+*              general case
+*
+               IF( I.LT.K ) THEN
+                  IF( LSAME( STOREV, 'C' ) ) THEN
+                     VII = V( N-K+I, I )
+                     V( N-K+I, I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+                     CALL ZGEMV( 'Conjugate transpose', N-K+I, K-I,
+     $                           -TAU( I ), V( 1, I+1 ), LDV, V( 1, I ),
+     $                           1, ZERO, T( I+1, I ), 1 )
+                     V( N-K+I, I ) = VII
+                  ELSE
+                     VII = V( I, N-K+I )
+                     V( I, N-K+I ) = ONE
+*
+*                    T(i+1:k,i) :=
+*                            - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
+                     CALL ZGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+     $                           V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                           T( I+1, I ), 1 )
+                     CALL ZLACGV( N-K+I-1, V( I, 1 ), LDV )
+                     V( I, N-K+I ) = VII
+                  END IF
+*
+*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+                  CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                        T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+               END IF
+               T( I, I ) = TAU( I )
+            END IF
+   40    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZLARFT
+*
+      END
diff --git a/src/lib/lapack/zlarfx.f b/src/lib/lapack/zlarfx.f
new file mode 100644
index 00000000..327b9d03
--- /dev/null
+++ b/src/lib/lapack/zlarfx.f
@@ -0,0 +1,641 @@
+      SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            LDC, M, N
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFX applies a complex elementary reflector H to a complex m by n
+*  matrix C, from either the left or the right. H is represented in the
+*  form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a complex scalar and v is a complex vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix
+*
+*  This version uses inline code if H has order < 11.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  V       (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'
+*                                        or (N) if SIDE = 'R'
+*          The vector v in the representation of H.
+*
+*  TAU     (input) COMPLEX*16
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the m by n matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDA >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'
+*                                            or (M) if SIDE = 'R'
+*          WORK is not referenced if H has order < 11.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J
+      COMPLEX*16         SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+     $                   V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZGEMV, ZGERC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( TAU.EQ.ZERO )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C, where H has order m.
+*
+         GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+     $           170, 190 )M
+*
+*        Code for general M
+*
+*        w := C'*v
+*
+         CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, 1,
+     $               ZERO, WORK, 1 )
+*
+*        C := C - tau * v * w'
+*
+         CALL ZGERC( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+         GO TO 410
+   10    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
+         DO 20 J = 1, N
+            C( 1, J ) = T1*C( 1, J )
+   20    CONTINUE
+         GO TO 410
+   30    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         DO 40 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+   40    CONTINUE
+         GO TO 410
+   50    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         DO 60 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+   60    CONTINUE
+         GO TO 410
+   70    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         DO 80 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+   80    CONTINUE
+         GO TO 410
+   90    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         DO 100 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+  100    CONTINUE
+         GO TO 410
+  110    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         DO 120 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+  120    CONTINUE
+         GO TO 410
+  130    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         DO 140 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+  140    CONTINUE
+         GO TO 410
+  150    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         DO 160 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+  160    CONTINUE
+         GO TO 410
+  170    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         V9 = DCONJG( V( 9 ) )
+         T9 = TAU*DCONJG( V9 )
+         DO 180 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+  180    CONTINUE
+         GO TO 410
+  190    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = DCONJG( V( 1 ) )
+         T1 = TAU*DCONJG( V1 )
+         V2 = DCONJG( V( 2 ) )
+         T2 = TAU*DCONJG( V2 )
+         V3 = DCONJG( V( 3 ) )
+         T3 = TAU*DCONJG( V3 )
+         V4 = DCONJG( V( 4 ) )
+         T4 = TAU*DCONJG( V4 )
+         V5 = DCONJG( V( 5 ) )
+         T5 = TAU*DCONJG( V5 )
+         V6 = DCONJG( V( 6 ) )
+         T6 = TAU*DCONJG( V6 )
+         V7 = DCONJG( V( 7 ) )
+         T7 = TAU*DCONJG( V7 )
+         V8 = DCONJG( V( 8 ) )
+         T8 = TAU*DCONJG( V8 )
+         V9 = DCONJG( V( 9 ) )
+         T9 = TAU*DCONJG( V9 )
+         V10 = DCONJG( V( 10 ) )
+         T10 = TAU*DCONJG( V10 )
+         DO 200 J = 1, N
+            SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+     $            V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+     $            V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+     $            V10*C( 10, J )
+            C( 1, J ) = C( 1, J ) - SUM*T1
+            C( 2, J ) = C( 2, J ) - SUM*T2
+            C( 3, J ) = C( 3, J ) - SUM*T3
+            C( 4, J ) = C( 4, J ) - SUM*T4
+            C( 5, J ) = C( 5, J ) - SUM*T5
+            C( 6, J ) = C( 6, J ) - SUM*T6
+            C( 7, J ) = C( 7, J ) - SUM*T7
+            C( 8, J ) = C( 8, J ) - SUM*T8
+            C( 9, J ) = C( 9, J ) - SUM*T9
+            C( 10, J ) = C( 10, J ) - SUM*T10
+  200    CONTINUE
+         GO TO 410
+      ELSE
+*
+*        Form  C * H, where H has order n.
+*
+         GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+     $           370, 390 )N
+*
+*        Code for general N
+*
+*        w := C * v
+*
+         CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+     $               WORK, 1 )
+*
+*        C := C - tau * w * v'
+*
+         CALL ZGERC( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+         GO TO 410
+  210    CONTINUE
+*
+*        Special code for 1 x 1 Householder
+*
+         T1 = ONE - TAU*V( 1 )*DCONJG( V( 1 ) )
+         DO 220 J = 1, M
+            C( J, 1 ) = T1*C( J, 1 )
+  220    CONTINUE
+         GO TO 410
+  230    CONTINUE
+*
+*        Special code for 2 x 2 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         DO 240 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+  240    CONTINUE
+         GO TO 410
+  250    CONTINUE
+*
+*        Special code for 3 x 3 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         DO 260 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+  260    CONTINUE
+         GO TO 410
+  270    CONTINUE
+*
+*        Special code for 4 x 4 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         DO 280 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+  280    CONTINUE
+         GO TO 410
+  290    CONTINUE
+*
+*        Special code for 5 x 5 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         DO 300 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+  300    CONTINUE
+         GO TO 410
+  310    CONTINUE
+*
+*        Special code for 6 x 6 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         DO 320 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+  320    CONTINUE
+         GO TO 410
+  330    CONTINUE
+*
+*        Special code for 7 x 7 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         DO 340 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+  340    CONTINUE
+         GO TO 410
+  350    CONTINUE
+*
+*        Special code for 8 x 8 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         DO 360 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+  360    CONTINUE
+         GO TO 410
+  370    CONTINUE
+*
+*        Special code for 9 x 9 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*DCONJG( V9 )
+         DO 380 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+  380    CONTINUE
+         GO TO 410
+  390    CONTINUE
+*
+*        Special code for 10 x 10 Householder
+*
+         V1 = V( 1 )
+         T1 = TAU*DCONJG( V1 )
+         V2 = V( 2 )
+         T2 = TAU*DCONJG( V2 )
+         V3 = V( 3 )
+         T3 = TAU*DCONJG( V3 )
+         V4 = V( 4 )
+         T4 = TAU*DCONJG( V4 )
+         V5 = V( 5 )
+         T5 = TAU*DCONJG( V5 )
+         V6 = V( 6 )
+         T6 = TAU*DCONJG( V6 )
+         V7 = V( 7 )
+         T7 = TAU*DCONJG( V7 )
+         V8 = V( 8 )
+         T8 = TAU*DCONJG( V8 )
+         V9 = V( 9 )
+         T9 = TAU*DCONJG( V9 )
+         V10 = V( 10 )
+         T10 = TAU*DCONJG( V10 )
+         DO 400 J = 1, M
+            SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+     $            V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+     $            V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+     $            V10*C( J, 10 )
+            C( J, 1 ) = C( J, 1 ) - SUM*T1
+            C( J, 2 ) = C( J, 2 ) - SUM*T2
+            C( J, 3 ) = C( J, 3 ) - SUM*T3
+            C( J, 4 ) = C( J, 4 ) - SUM*T4
+            C( J, 5 ) = C( J, 5 ) - SUM*T5
+            C( J, 6 ) = C( J, 6 ) - SUM*T6
+            C( J, 7 ) = C( J, 7 ) - SUM*T7
+            C( J, 8 ) = C( J, 8 ) - SUM*T8
+            C( J, 9 ) = C( J, 9 ) - SUM*T9
+            C( J, 10 ) = C( J, 10 ) - SUM*T10
+  400    CONTINUE
+         GO TO 410
+      END IF
+  410 CONTINUE
+      RETURN
+*
+*     End of ZLARFX
+*
+      END
diff --git a/src/lib/lapack/zlartg.f b/src/lib/lapack/zlartg.f
new file mode 100644
index 00000000..6d3a850e
--- /dev/null
+++ b/src/lib/lapack/zlartg.f
@@ -0,0 +1,195 @@
+      SUBROUTINE ZLARTG( F, G, CS, SN, R )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   CS
+      COMPLEX*16         F, G, R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARTG generates a plane rotation so that
+*
+*     [  CS  SN  ]     [ F ]     [ R ]
+*     [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
+*     [ -SN  CS  ]     [ G ]     [ 0 ]
+*
+*  This is a faster version of the BLAS1 routine ZROTG, except for
+*  the following differences:
+*     F and G are unchanged on return.
+*     If G=0, then CS=1 and SN=0.
+*     If F=0, then CS=0 and SN is chosen so that R is real.
+*
+*  Arguments
+*  =========
+*
+*  F       (input) COMPLEX*16
+*          The first component of vector to be rotated.
+*
+*  G       (input) COMPLEX*16
+*          The second component of vector to be rotated.
+*
+*  CS      (output) DOUBLE PRECISION
+*          The cosine of the rotation.
+*
+*  SN      (output) COMPLEX*16
+*          The sine of the rotation.
+*
+*  R       (output) COMPLEX*16
+*          The nonzero component of the rotated vector.
+*
+*  Further Details
+*  ======= =======
+*
+*  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
+*
+*  This version has a few statements commented out for thread safety
+*  (machine parameters are computed on each entry). 10 feb 03, SJH.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   TWO, ONE, ZERO
+      PARAMETER          ( TWO = 2.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+*     LOGICAL            FIRST
+      INTEGER            COUNT, I
+      DOUBLE PRECISION   D, DI, DR, EPS, F2, F2S, G2, G2S, SAFMIN,
+     $                   SAFMN2, SAFMX2, SCALE
+      COMPLEX*16         FF, FS, GS
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, LOG,
+     $                   MAX, SQRT
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1, ABSSQ
+*     ..
+*     .. Save statement ..
+*     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
+*     ..
+*     .. Data statements ..
+*     DATA               FIRST / .TRUE. /
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( FF ) = MAX( ABS( DBLE( FF ) ), ABS( DIMAG( FF ) ) )
+      ABSSQ( FF ) = DBLE( FF )**2 + DIMAG( FF )**2
+*     ..
+*     .. Executable Statements ..
+*
+*     IF( FIRST ) THEN
+         SAFMIN = DLAMCH( 'S' )
+         EPS = DLAMCH( 'E' )
+         SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+     $            LOG( DLAMCH( 'B' ) ) / TWO )
+         SAFMX2 = ONE / SAFMN2
+*        FIRST = .FALSE.
+*     END IF
+      SCALE = MAX( ABS1( F ), ABS1( G ) )
+      FS = F
+      GS = G
+      COUNT = 0
+      IF( SCALE.GE.SAFMX2 ) THEN
+   10    CONTINUE
+         COUNT = COUNT + 1
+         FS = FS*SAFMN2
+         GS = GS*SAFMN2
+         SCALE = SCALE*SAFMN2
+         IF( SCALE.GE.SAFMX2 )
+     $      GO TO 10
+      ELSE IF( SCALE.LE.SAFMN2 ) THEN
+         IF( G.EQ.CZERO ) THEN
+            CS = ONE
+            SN = CZERO
+            R = F
+            RETURN
+         END IF
+   20    CONTINUE
+         COUNT = COUNT - 1
+         FS = FS*SAFMX2
+         GS = GS*SAFMX2
+         SCALE = SCALE*SAFMX2
+         IF( SCALE.LE.SAFMN2 )
+     $      GO TO 20
+      END IF
+      F2 = ABSSQ( FS )
+      G2 = ABSSQ( GS )
+      IF( F2.LE.MAX( G2, ONE )*SAFMIN ) THEN
+*
+*        This is a rare case: F is very small.
+*
+         IF( F.EQ.CZERO ) THEN
+            CS = ZERO
+            R = DLAPY2( DBLE( G ), DIMAG( G ) )
+*           Do complex/real division explicitly with two real divisions
+            D = DLAPY2( DBLE( GS ), DIMAG( GS ) )
+            SN = DCMPLX( DBLE( GS ) / D, -DIMAG( GS ) / D )
+            RETURN
+         END IF
+         F2S = DLAPY2( DBLE( FS ), DIMAG( FS ) )
+*        G2 and G2S are accurate
+*        G2 is at least SAFMIN, and G2S is at least SAFMN2
+         G2S = SQRT( G2 )
+*        Error in CS from underflow in F2S is at most
+*        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
+*        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
+*        and so CS .lt. sqrt(SAFMIN)
+*        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
+*        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
+*        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
+         CS = F2S / G2S
+*        Make sure abs(FF) = 1
+*        Do complex/real division explicitly with 2 real divisions
+         IF( ABS1( F ).GT.ONE ) THEN
+            D = DLAPY2( DBLE( F ), DIMAG( F ) )
+            FF = DCMPLX( DBLE( F ) / D, DIMAG( F ) / D )
+         ELSE
+            DR = SAFMX2*DBLE( F )
+            DI = SAFMX2*DIMAG( F )
+            D = DLAPY2( DR, DI )
+            FF = DCMPLX( DR / D, DI / D )
+         END IF
+         SN = FF*DCMPLX( DBLE( GS ) / G2S, -DIMAG( GS ) / G2S )
+         R = CS*F + SN*G
+      ELSE
+*
+*        This is the most common case.
+*        Neither F2 nor F2/G2 are less than SAFMIN
+*        F2S cannot overflow, and it is accurate
+*
+         F2S = SQRT( ONE+G2 / F2 )
+*        Do the F2S(real)*FS(complex) multiply with two real multiplies
+         R = DCMPLX( F2S*DBLE( FS ), F2S*DIMAG( FS ) )
+         CS = ONE / F2S
+         D = F2 + G2
+*        Do complex/real division explicitly with two real divisions
+         SN = DCMPLX( DBLE( R ) / D, DIMAG( R ) / D )
+         SN = SN*DCONJG( GS )
+         IF( COUNT.NE.0 ) THEN
+            IF( COUNT.GT.0 ) THEN
+               DO 30 I = 1, COUNT
+                  R = R*SAFMX2
+   30          CONTINUE
+            ELSE
+               DO 40 I = 1, -COUNT
+                  R = R*SAFMN2
+   40          CONTINUE
+            END IF
+         END IF
+      END IF
+      RETURN
+*
+*     End of ZLARTG
+*
+      END
diff --git a/src/lib/lapack/zlarz.f b/src/lib/lapack/zlarz.f
new file mode 100644
index 00000000..18124672
--- /dev/null
+++ b/src/lib/lapack/zlarz.f
@@ -0,0 +1,157 @@
+      SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE
+      INTEGER            INCV, L, LDC, M, N
+      COMPLEX*16         TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARZ applies a complex elementary reflector H to a complex
+*  M-by-N matrix C, from either the left or the right. H is represented
+*  in the form
+*
+*        H = I - tau * v * v'
+*
+*  where tau is a complex scalar and v is a complex vector.
+*
+*  If tau = 0, then H is taken to be the unit matrix.
+*
+*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
+*  tau.
+*
+*  H is a product of k elementary reflectors as returned by ZTZRZF.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': form  H * C
+*          = 'R': form  C * H
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  L       (input) INTEGER
+*          The number of entries of the vector V containing
+*          the meaningful part of the Householder vectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  V       (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))
+*          The vector v in the representation of H as returned by
+*          ZTZRZF. V is not used if TAU = 0.
+*
+*  INCV    (input) INTEGER
+*          The increment between elements of v. INCV <> 0.
+*
+*  TAU     (input) COMPLEX*16
+*          The value tau in the representation of H.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+*          or C * H if SIDE = 'R'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                         (N) if SIDE = 'L'
+*                      or (M) if SIDE = 'R'
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZCOPY, ZGEMV, ZGERC, ZGERU, ZLACGV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w( 1:n ) = conjg( C( 1, 1:n ) )
+*
+            CALL ZCOPY( N, C, LDC, WORK, 1 )
+            CALL ZLACGV( N, WORK, 1 )
+*
+*           w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) )
+*
+            CALL ZGEMV( 'Conjugate transpose', L, N, ONE, C( M-L+1, 1 ),
+     $                  LDC, V, INCV, ONE, WORK, 1 )
+            CALL ZLACGV( N, WORK, 1 )
+*
+*           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
+*
+            CALL ZAXPY( N, -TAU, WORK, 1, C, LDC )
+*
+*           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+*                               tau * v( 1:l ) * conjg( w( 1:n )' )
+*
+            CALL ZGERU( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
+     $                  LDC )
+         END IF
+*
+      ELSE
+*
+*        Form  C * H
+*
+         IF( TAU.NE.ZERO ) THEN
+*
+*           w( 1:m ) = C( 1:m, 1 )
+*
+            CALL ZCOPY( M, C, 1, WORK, 1 )
+*
+*           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+            CALL ZGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
+     $                  V, INCV, ONE, WORK, 1 )
+*
+*           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
+*
+            CALL ZAXPY( M, -TAU, WORK, 1, C, 1 )
+*
+*           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+*                               tau * w( 1:m ) * v( 1:l )'
+*
+            CALL ZGERC( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+     $                  LDC )
+*
+         END IF
+*
+      END IF
+*
+      RETURN
+*
+*     End of ZLARZ
+*
+      END
diff --git a/src/lib/lapack/zlarzb.f b/src/lib/lapack/zlarzb.f
new file mode 100644
index 00000000..05d2a0e3
--- /dev/null
+++ b/src/lib/lapack/zlarzb.f
@@ -0,0 +1,234 @@
+      SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
+     $                   LDV, T, LDT, C, LDC, WORK, LDWORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, SIDE, STOREV, TRANS
+      INTEGER            K, L, LDC, LDT, LDV, LDWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
+     $                   WORK( LDWORK, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARZB applies a complex block reflector H or its transpose H**H
+*  to a complex distributed M-by-N  C from the left or the right.
+*
+*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply H or H' from the Left
+*          = 'R': apply H or H' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply H (No transpose)
+*          = 'C': apply H' (Conjugate transpose)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Indicates how H is formed from a product of elementary
+*          reflectors
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Indicates how the vectors which define the elementary
+*          reflectors are stored:
+*          = 'C': Columnwise                        (not supported yet)
+*          = 'R': Rowwise
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C.
+*
+*  K       (input) INTEGER
+*          The order of the matrix T (= the number of elementary
+*          reflectors whose product defines the block reflector).
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix V containing the
+*          meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  V       (input) COMPLEX*16 array, dimension (LDV,NV).
+*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
+*
+*  T       (input) COMPLEX*16 array, dimension (LDT,K)
+*          The triangular K-by-K matrix T in the representation of the
+*          block reflector.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
+*
+*  LDWORK  (input) INTEGER
+*          The leading dimension of the array WORK.
+*          If SIDE = 'L', LDWORK >= max(1,N);
+*          if SIDE = 'R', LDWORK >= max(1,M).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      CHARACTER          TRANST
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZGEMM, ZLACGV, ZTRMM
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 .OR. N.LE.0 )
+     $   RETURN
+*
+*     Check for currently supported options
+*
+      INFO = 0
+      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLARZB', -INFO )
+         RETURN
+      END IF
+*
+      IF( LSAME( TRANS, 'N' ) ) THEN
+         TRANST = 'C'
+      ELSE
+         TRANST = 'N'
+      END IF
+*
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  H * C  or  H' * C
+*
+*        W( 1:n, 1:k ) = conjg( C( 1:k, 1:n )' )
+*
+         DO 10 J = 1, K
+            CALL ZCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+   10    CONTINUE
+*
+*        W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
+*                        conjg( C( m-l+1:m, 1:n )' ) * V( 1:k, 1:l )'
+*
+         IF( L.GT.0 )
+     $      CALL ZGEMM( 'Transpose', 'Conjugate transpose', N, K, L,
+     $                  ONE, C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK,
+     $                  LDWORK )
+*
+*        W( 1:n, 1:k ) = W( 1:n, 1:k ) * T'  or  W( 1:m, 1:k ) * T
+*
+         CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
+     $               LDT, WORK, LDWORK )
+*
+*        C( 1:k, 1:n ) = C( 1:k, 1:n ) - conjg( W( 1:n, 1:k )' )
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, K
+               C( I, J ) = C( I, J ) - WORK( J, I )
+   20       CONTINUE
+   30    CONTINUE
+*
+*        C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+*                    conjg( V( 1:k, 1:l )' ) * conjg( W( 1:n, 1:k )' )
+*
+         IF( L.GT.0 )
+     $      CALL ZGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
+     $                  WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
+*
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        Form  C * H  or  C * H'
+*
+*        W( 1:m, 1:k ) = C( 1:m, 1:k )
+*
+         DO 40 J = 1, K
+            CALL ZCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+   40    CONTINUE
+*
+*        W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
+*                        C( 1:m, n-l+1:n ) * conjg( V( 1:k, 1:l )' )
+*
+         IF( L.GT.0 )
+     $      CALL ZGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
+     $                  C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+*        W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T )  or
+*                        W( 1:m, 1:k ) * conjg( T' )
+*
+         DO 50 J = 1, K
+            CALL ZLACGV( K-J+1, T( J, J ), 1 )
+   50    CONTINUE
+         CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
+     $               LDT, WORK, LDWORK )
+         DO 60 J = 1, K
+            CALL ZLACGV( K-J+1, T( J, J ), 1 )
+   60    CONTINUE
+*
+*        C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
+*
+         DO 80 J = 1, K
+            DO 70 I = 1, M
+               C( I, J ) = C( I, J ) - WORK( I, J )
+   70       CONTINUE
+   80    CONTINUE
+*
+*        C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+*                            W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) )
+*
+         DO 90 J = 1, L
+            CALL ZLACGV( K, V( 1, J ), 1 )
+   90    CONTINUE
+         IF( L.GT.0 )
+     $      CALL ZGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
+     $                  WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
+         DO 100 J = 1, L
+            CALL ZLACGV( K, V( 1, J ), 1 )
+  100    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of ZLARZB
+*
+      END
diff --git a/src/lib/lapack/zlarzt.f b/src/lib/lapack/zlarzt.f
new file mode 100644
index 00000000..9242ed36
--- /dev/null
+++ b/src/lib/lapack/zlarzt.f
@@ -0,0 +1,186 @@
+      SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, STOREV
+      INTEGER            K, LDT, LDV, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         T( LDT, * ), TAU( * ), V( LDV, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARZT forms the triangular factor T of a complex block reflector
+*  H of order > n, which is defined as a product of k elementary
+*  reflectors.
+*
+*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+*  If STOREV = 'C', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th column of the array V, and
+*
+*     H  =  I - V * T * V'
+*
+*  If STOREV = 'R', the vector which defines the elementary reflector
+*  H(i) is stored in the i-th row of the array V, and
+*
+*     H  =  I - V' * T * V
+*
+*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+*  Arguments
+*  =========
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies the order in which the elementary reflectors are
+*          multiplied to form the block reflector:
+*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+*  STOREV  (input) CHARACTER*1
+*          Specifies how the vectors which define the elementary
+*          reflectors are stored (see also Further Details):
+*          = 'C': columnwise                        (not supported yet)
+*          = 'R': rowwise
+*
+*  N       (input) INTEGER
+*          The order of the block reflector H. N >= 0.
+*
+*  K       (input) INTEGER
+*          The order of the triangular factor T (= the number of
+*          elementary reflectors). K >= 1.
+*
+*  V       (input/output) COMPLEX*16 array, dimension
+*                               (LDV,K) if STOREV = 'C'
+*                               (LDV,N) if STOREV = 'R'
+*          The matrix V. See further details.
+*
+*  LDV     (input) INTEGER
+*          The leading dimension of the array V.
+*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i).
+*
+*  T       (output) COMPLEX*16 array, dimension (LDT,K)
+*          The k by k triangular factor T of the block reflector.
+*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+*          lower triangular. The rest of the array is not used.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= K.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The shape of the matrix V and the storage of the vectors which define
+*  the H(i) is best illustrated by the following example with n = 5 and
+*  k = 3. The elements equal to 1 are not stored; the corresponding
+*  array elements are modified but restored on exit. The rest of the
+*  array is not used.
+*
+*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
+*
+*                                              ______V_____
+*         ( v1 v2 v3 )                        /            \
+*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
+*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
+*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
+*         ( v1 v2 v3 )
+*            .  .  .
+*            .  .  .
+*            1  .  .
+*               1  .
+*                  1
+*
+*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
+*
+*                                                        ______V_____
+*            1                                          /            \
+*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
+*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
+*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
+*            .  .  .
+*         ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*     V = ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*         ( v1 v2 v3 )
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMV, ZLACGV, ZTRMV
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Executable Statements ..
+*
+*     Check for currently supported options
+*
+      INFO = 0
+      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+         INFO = -2
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLARZT', -INFO )
+         RETURN
+      END IF
+*
+      DO 20 I = K, 1, -1
+         IF( TAU( I ).EQ.ZERO ) THEN
+*
+*           H(i)  =  I
+*
+            DO 10 J = I, K
+               T( J, I ) = ZERO
+   10       CONTINUE
+         ELSE
+*
+*           general case
+*
+            IF( I.LT.K ) THEN
+*
+*              T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
+*
+               CALL ZLACGV( N, V( I, 1 ), LDV )
+               CALL ZGEMV( 'No transpose', K-I, N, -TAU( I ),
+     $                     V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+     $                     T( I+1, I ), 1 )
+               CALL ZLACGV( N, V( I, 1 ), LDV )
+*
+*              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+               CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+     $                     T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+            END IF
+            T( I, I ) = TAU( I )
+         END IF
+   20 CONTINUE
+      RETURN
+*
+*     End of ZLARZT
+*
+      END
diff --git a/src/lib/lapack/zlascl.f b/src/lib/lapack/zlascl.f
new file mode 100644
index 00000000..36bb2445
--- /dev/null
+++ b/src/lib/lapack/zlascl.f
@@ -0,0 +1,267 @@
+      SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TYPE
+      INTEGER            INFO, KL, KU, LDA, M, N
+      DOUBLE PRECISION   CFROM, CTO
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASCL multiplies the M by N complex matrix A by the real scalar
+*  CTO/CFROM.  This is done without over/underflow as long as the final
+*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
+*  A may be full, upper triangular, lower triangular, upper Hessenberg,
+*  or banded.
+*
+*  Arguments
+*  =========
+*
+*  TYPE    (input) CHARACTER*1
+*          TYPE indices the storage type of the input matrix.
+*          = 'G':  A is a full matrix.
+*          = 'L':  A is a lower triangular matrix.
+*          = 'U':  A is an upper triangular matrix.
+*          = 'H':  A is an upper Hessenberg matrix.
+*          = 'B':  A is a symmetric band matrix with lower bandwidth KL
+*                  and upper bandwidth KU and with the only the lower
+*                  half stored.
+*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL
+*                  and upper bandwidth KU and with the only the upper
+*                  half stored.
+*          = 'Z':  A is a band matrix with lower bandwidth KL and upper
+*                  bandwidth KU.
+*
+*  KL      (input) INTEGER
+*          The lower bandwidth of A.  Referenced only if TYPE = 'B',
+*          'Q' or 'Z'.
+*
+*  KU      (input) INTEGER
+*          The upper bandwidth of A.  Referenced only if TYPE = 'B',
+*          'Q' or 'Z'.
+*
+*  CFROM   (input) DOUBLE PRECISION
+*  CTO     (input) DOUBLE PRECISION
+*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
+*          without over/underflow if the final result CTO*A(I,J)/CFROM
+*          can be represented without over/underflow.  CFROM must be
+*          nonzero.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the
+*          storage type.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  INFO    (output) INTEGER
+*          0  - successful exit
+*          <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DONE
+      INTEGER            I, ITYPE, J, K1, K2, K3, K4
+      DOUBLE PRECISION   BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           LSAME, DLAMCH
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+*
+      IF( LSAME( TYPE, 'G' ) ) THEN
+         ITYPE = 0
+      ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+         ITYPE = 1
+      ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+         ITYPE = 2
+      ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+         ITYPE = 3
+      ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+         ITYPE = 4
+      ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+         ITYPE = 5
+      ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+         ITYPE = 6
+      ELSE
+         ITYPE = -1
+      END IF
+*
+      IF( ITYPE.EQ.-1 ) THEN
+         INFO = -1
+      ELSE IF( CFROM.EQ.ZERO ) THEN
+         INFO = -4
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+     $         ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+         INFO = -7
+      ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -9
+      ELSE IF( ITYPE.GE.4 ) THEN
+         IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+            INFO = -2
+         ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+     $            ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+     $             THEN
+            INFO = -3
+         ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+     $            ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+     $            ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+            INFO = -9
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLASCL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 .OR. M.EQ.0 )
+     $   RETURN
+*
+*     Get machine parameters
+*
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+*
+      CFROMC = CFROM
+      CTOC = CTO
+*
+   10 CONTINUE
+      CFROM1 = CFROMC*SMLNUM
+      CTO1 = CTOC / BIGNUM
+      IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+         MUL = SMLNUM
+         DONE = .FALSE.
+         CFROMC = CFROM1
+      ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+         MUL = BIGNUM
+         DONE = .FALSE.
+         CTOC = CTO1
+      ELSE
+         MUL = CTOC / CFROMC
+         DONE = .TRUE.
+      END IF
+*
+      IF( ITYPE.EQ.0 ) THEN
+*
+*        Full matrix
+*
+         DO 30 J = 1, N
+            DO 20 I = 1, M
+               A( I, J ) = A( I, J )*MUL
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.1 ) THEN
+*
+*        Lower triangular matrix
+*
+         DO 50 J = 1, N
+            DO 40 I = J, M
+               A( I, J ) = A( I, J )*MUL
+   40       CONTINUE
+   50    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.2 ) THEN
+*
+*        Upper triangular matrix
+*
+         DO 70 J = 1, N
+            DO 60 I = 1, MIN( J, M )
+               A( I, J ) = A( I, J )*MUL
+   60       CONTINUE
+   70    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.3 ) THEN
+*
+*        Upper Hessenberg matrix
+*
+         DO 90 J = 1, N
+            DO 80 I = 1, MIN( J+1, M )
+               A( I, J ) = A( I, J )*MUL
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.4 ) THEN
+*
+*        Lower half of a symmetric band matrix
+*
+         K3 = KL + 1
+         K4 = N + 1
+         DO 110 J = 1, N
+            DO 100 I = 1, MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  100       CONTINUE
+  110    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.5 ) THEN
+*
+*        Upper half of a symmetric band matrix
+*
+         K1 = KU + 2
+         K3 = KU + 1
+         DO 130 J = 1, N
+            DO 120 I = MAX( K1-J, 1 ), K3
+               A( I, J ) = A( I, J )*MUL
+  120       CONTINUE
+  130    CONTINUE
+*
+      ELSE IF( ITYPE.EQ.6 ) THEN
+*
+*        Band matrix
+*
+         K1 = KL + KU + 2
+         K2 = KL + 1
+         K3 = 2*KL + KU + 1
+         K4 = KL + KU + 1 + M
+         DO 150 J = 1, N
+            DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+               A( I, J ) = A( I, J )*MUL
+  140       CONTINUE
+  150    CONTINUE
+*
+      END IF
+*
+      IF( .NOT.DONE )
+     $   GO TO 10
+*
+      RETURN
+*
+*     End of ZLASCL
+*
+      END
diff --git a/src/lib/lapack/zlaset.f b/src/lib/lapack/zlaset.f
new file mode 100644
index 00000000..88fc21b2
--- /dev/null
+++ b/src/lib/lapack/zlaset.f
@@ -0,0 +1,114 @@
+      SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, M, N
+      COMPLEX*16         ALPHA, BETA
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASET initializes a 2-D array A to BETA on the diagonal and
+*  ALPHA on the offdiagonals.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies the part of the matrix A to be set.
+*          = 'U':      Upper triangular part is set. The lower triangle
+*                      is unchanged.
+*          = 'L':      Lower triangular part is set. The upper triangle
+*                      is unchanged.
+*          Otherwise:  All of the matrix A is set.
+*
+*  M       (input) INTEGER
+*          On entry, M specifies the number of rows of A.
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the number of columns of A.
+*
+*  ALPHA   (input) COMPLEX*16
+*          All the offdiagonal array elements are set to ALPHA.
+*
+*  BETA    (input) COMPLEX*16
+*          All the diagonal array elements are set to BETA.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the m by n matrix A.
+*          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;
+*                   A(i,i) = BETA , 1 <= i <= min(m,n)
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, J
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MIN
+*     ..
+*     .. Executable Statements ..
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Set the diagonal to BETA and the strictly upper triangular
+*        part of the array to ALPHA.
+*
+         DO 20 J = 2, N
+            DO 10 I = 1, MIN( J-1, M )
+               A( I, J ) = ALPHA
+   10       CONTINUE
+   20    CONTINUE
+         DO 30 I = 1, MIN( N, M )
+            A( I, I ) = BETA
+   30    CONTINUE
+*
+      ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+*
+*        Set the diagonal to BETA and the strictly lower triangular
+*        part of the array to ALPHA.
+*
+         DO 50 J = 1, MIN( M, N )
+            DO 40 I = J + 1, M
+               A( I, J ) = ALPHA
+   40       CONTINUE
+   50    CONTINUE
+         DO 60 I = 1, MIN( N, M )
+            A( I, I ) = BETA
+   60    CONTINUE
+*
+      ELSE
+*
+*        Set the array to BETA on the diagonal and ALPHA on the
+*        offdiagonal.
+*
+         DO 80 J = 1, N
+            DO 70 I = 1, M
+               A( I, J ) = ALPHA
+   70       CONTINUE
+   80    CONTINUE
+         DO 90 I = 1, MIN( M, N )
+            A( I, I ) = BETA
+   90    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLASET
+*
+      END
diff --git a/src/lib/lapack/zlasr.f b/src/lib/lapack/zlasr.f
new file mode 100644
index 00000000..507a20c4
--- /dev/null
+++ b/src/lib/lapack/zlasr.f
@@ -0,0 +1,363 @@
+      SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIRECT, PIVOT, SIDE
+      INTEGER            LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   C( * ), S( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASR applies a sequence of real plane rotations to a complex matrix
+*  A, from either the left or the right.
+*
+*  When SIDE = 'L', the transformation takes the form
+*
+*     A := P*A
+*
+*  and when SIDE = 'R', the transformation takes the form
+*
+*     A := A*P**T
+*
+*  where P is an orthogonal matrix consisting of a sequence of z plane
+*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
+*  and P**T is the transpose of P.
+*  
+*  When DIRECT = 'F' (Forward sequence), then
+*  
+*     P = P(z-1) * ... * P(2) * P(1)
+*  
+*  and when DIRECT = 'B' (Backward sequence), then
+*  
+*     P = P(1) * P(2) * ... * P(z-1)
+*  
+*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
+*  
+*     R(k) = (  c(k)  s(k) )
+*          = ( -s(k)  c(k) ).
+*  
+*  When PIVOT = 'V' (Variable pivot), the rotation is performed
+*  for the plane (k,k+1), i.e., P(k) has the form
+*  
+*     P(k) = (  1                                            )
+*            (       ...                                     )
+*            (              1                                )
+*            (                   c(k)  s(k)                  )
+*            (                  -s(k)  c(k)                  )
+*            (                                1              )
+*            (                                     ...       )
+*            (                                            1  )
+*  
+*  where R(k) appears as a rank-2 modification to the identity matrix in
+*  rows and columns k and k+1.
+*  
+*  When PIVOT = 'T' (Top pivot), the rotation is performed for the
+*  plane (1,k+1), so P(k) has the form
+*  
+*     P(k) = (  c(k)                    s(k)                 )
+*            (         1                                     )
+*            (              ...                              )
+*            (                     1                         )
+*            ( -s(k)                    c(k)                 )
+*            (                                 1             )
+*            (                                      ...      )
+*            (                                             1 )
+*  
+*  where R(k) appears in rows and columns 1 and k+1.
+*  
+*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
+*  performed for the plane (k,z), giving P(k) the form
+*  
+*     P(k) = ( 1                                             )
+*            (      ...                                      )
+*            (             1                                 )
+*            (                  c(k)                    s(k) )
+*            (                         1                     )
+*            (                              ...              )
+*            (                                     1         )
+*            (                 -s(k)                    c(k) )
+*  
+*  where R(k) appears in rows and columns k and z.  The rotations are
+*  performed without ever forming P(k) explicitly.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          Specifies whether the plane rotation matrix P is applied to
+*          A on the left or the right.
+*          = 'L':  Left, compute A := P*A
+*          = 'R':  Right, compute A:= A*P**T
+*
+*  PIVOT   (input) CHARACTER*1
+*          Specifies the plane for which P(k) is a plane rotation
+*          matrix.
+*          = 'V':  Variable pivot, the plane (k,k+1)
+*          = 'T':  Top pivot, the plane (1,k+1)
+*          = 'B':  Bottom pivot, the plane (k,z)
+*
+*  DIRECT  (input) CHARACTER*1
+*          Specifies whether P is a forward or backward sequence of
+*          plane rotations.
+*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)
+*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  If m <= 1, an immediate
+*          return is effected.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  If n <= 1, an
+*          immediate return is effected.
+*
+*  C       (input) DOUBLE PRECISION array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The cosines c(k) of the plane rotations.
+*
+*  S       (input) DOUBLE PRECISION array, dimension
+*                  (M-1) if SIDE = 'L'
+*                  (N-1) if SIDE = 'R'
+*          The sines s(k) of the plane rotations.  The 2-by-2 plane
+*          rotation part of the matrix P(k), R(k), has the form
+*          R(k) = (  c(k)  s(k) )
+*                 ( -s(k)  c(k) ).
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          The M-by-N matrix A.  On exit, A is overwritten by P*A if
+*          SIDE = 'R' or by A*P**T if SIDE = 'L'.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J
+      DOUBLE PRECISION   CTEMP, STEMP
+      COMPLEX*16         TEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters
+*
+      INFO = 0
+      IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
+         INFO = 1
+      ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
+     $         'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
+         INFO = 2
+      ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
+     $          THEN
+         INFO = 3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = 4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = 5
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = 9
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLASR ', INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+     $   RETURN
+      IF( LSAME( SIDE, 'L' ) ) THEN
+*
+*        Form  P * A
+*
+         IF( LSAME( PIVOT, 'V' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 20 J = 1, M - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 10 I = 1, N
+                        TEMP = A( J+1, I )
+                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+   10                CONTINUE
+                  END IF
+   20          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 40 J = M - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 30 I = 1, N
+                        TEMP = A( J+1, I )
+                        A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+                        A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+   30                CONTINUE
+                  END IF
+   40          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 60 J = 2, M
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 50 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+   50                CONTINUE
+                  END IF
+   60          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 80 J = M, 2, -1
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 70 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+                        A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+   70                CONTINUE
+                  END IF
+   80          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 100 J = 1, M - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 90 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+   90                CONTINUE
+                  END IF
+  100          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 120 J = M - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 110 I = 1, N
+                        TEMP = A( J, I )
+                        A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+                        A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+  110                CONTINUE
+                  END IF
+  120          CONTINUE
+            END IF
+         END IF
+      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+*        Form A * P'
+*
+         IF( LSAME( PIVOT, 'V' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 140 J = 1, N - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 130 I = 1, M
+                        TEMP = A( I, J+1 )
+                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+  130                CONTINUE
+                  END IF
+  140          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 160 J = N - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 150 I = 1, M
+                        TEMP = A( I, J+1 )
+                        A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+                        A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+  150                CONTINUE
+                  END IF
+  160          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 180 J = 2, N
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 170 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+  170                CONTINUE
+                  END IF
+  180          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 200 J = N, 2, -1
+                  CTEMP = C( J-1 )
+                  STEMP = S( J-1 )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 190 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+                        A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+  190                CONTINUE
+                  END IF
+  200          CONTINUE
+            END IF
+         ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+            IF( LSAME( DIRECT, 'F' ) ) THEN
+               DO 220 J = 1, N - 1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 210 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+  210                CONTINUE
+                  END IF
+  220          CONTINUE
+            ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+               DO 240 J = N - 1, 1, -1
+                  CTEMP = C( J )
+                  STEMP = S( J )
+                  IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+                     DO 230 I = 1, M
+                        TEMP = A( I, J )
+                        A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+                        A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+  230                CONTINUE
+                  END IF
+  240          CONTINUE
+            END IF
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLASR
+*
+      END
diff --git a/src/lib/lapack/zlassq.f b/src/lib/lapack/zlassq.f
new file mode 100644
index 00000000..a209984b
--- /dev/null
+++ b/src/lib/lapack/zlassq.f
@@ -0,0 +1,101 @@
+      SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      DOUBLE PRECISION   SCALE, SUMSQ
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASSQ returns the values scl and ssq such that
+*
+*     ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
+*
+*  where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is
+*  assumed to be at least unity and the value of ssq will then satisfy
+*
+*     1.0 .le. ssq .le. ( sumsq + 2*n ).
+*
+*  scale is assumed to be non-negative and scl returns the value
+*
+*     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),
+*            i
+*
+*  scale and sumsq must be supplied in SCALE and SUMSQ respectively.
+*  SCALE and SUMSQ are overwritten by scl and ssq respectively.
+*
+*  The routine makes only one pass through the vector X.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements to be used from the vector X.
+*
+*  X       (input) COMPLEX*16 array, dimension (N)
+*          The vector x as described above.
+*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of the vector X.
+*          INCX > 0.
+*
+*  SCALE   (input/output) DOUBLE PRECISION
+*          On entry, the value  scale  in the equation above.
+*          On exit, SCALE is overwritten with the value  scl .
+*
+*  SUMSQ   (input/output) DOUBLE PRECISION
+*          On entry, the value  sumsq  in the equation above.
+*          On exit, SUMSQ is overwritten with the value  ssq .
+*
+* =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO
+      PARAMETER          ( ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            IX
+      DOUBLE PRECISION   TEMP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DIMAG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.GT.0 ) THEN
+         DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
+            IF( DBLE( X( IX ) ).NE.ZERO ) THEN
+               TEMP1 = ABS( DBLE( X( IX ) ) )
+               IF( SCALE.LT.TEMP1 ) THEN
+                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
+                  SCALE = TEMP1
+               ELSE
+                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
+               END IF
+            END IF
+            IF( DIMAG( X( IX ) ).NE.ZERO ) THEN
+               TEMP1 = ABS( DIMAG( X( IX ) ) )
+               IF( SCALE.LT.TEMP1 ) THEN
+                  SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2
+                  SCALE = TEMP1
+               ELSE
+                  SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2
+               END IF
+            END IF
+   10    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLASSQ
+*
+      END
diff --git a/src/lib/lapack/zlaswp.f b/src/lib/lapack/zlaswp.f
new file mode 100644
index 00000000..8b07e48b
--- /dev/null
+++ b/src/lib/lapack/zlaswp.f
@@ -0,0 +1,119 @@
+      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, K1, K2, LDA, N
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * )
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLASWP performs a series of row interchanges on the matrix A.
+*  One row interchange is initiated for each of rows K1 through K2 of A.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the matrix of column dimension N to which the row
+*          interchanges will be applied.
+*          On exit, the permuted matrix.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*
+*  K1      (input) INTEGER
+*          The first element of IPIV for which a row interchange will
+*          be done.
+*
+*  K2      (input) INTEGER
+*          The last element of IPIV for which a row interchange will
+*          be done.
+*
+*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))
+*          The vector of pivot indices.  Only the elements in positions
+*          K1 through K2 of IPIV are accessed.
+*          IPIV(K) = L implies rows K and L are to be interchanged.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of IPIV.  If IPIV
+*          is negative, the pivots are applied in reverse order.
+*
+*  Further Details
+*  ===============
+*
+*  Modified by
+*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
+      COMPLEX*16         TEMP
+*     ..
+*     .. Executable Statements ..
+*
+*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+      IF( INCX.GT.0 ) THEN
+         IX0 = K1
+         I1 = K1
+         I2 = K2
+         INC = 1
+      ELSE IF( INCX.LT.0 ) THEN
+         IX0 = 1 + ( 1-K2 )*INCX
+         I1 = K2
+         I2 = K1
+         INC = -1
+      ELSE
+         RETURN
+      END IF
+*
+      N32 = ( N / 32 )*32
+      IF( N32.NE.0 ) THEN
+         DO 30 J = 1, N32, 32
+            IX = IX0
+            DO 20 I = I1, I2, INC
+               IP = IPIV( IX )
+               IF( IP.NE.I ) THEN
+                  DO 10 K = J, J + 31
+                     TEMP = A( I, K )
+                     A( I, K ) = A( IP, K )
+                     A( IP, K ) = TEMP
+   10             CONTINUE
+               END IF
+               IX = IX + INCX
+   20       CONTINUE
+   30    CONTINUE
+      END IF
+      IF( N32.NE.N ) THEN
+         N32 = N32 + 1
+         IX = IX0
+         DO 50 I = I1, I2, INC
+            IP = IPIV( IX )
+            IF( IP.NE.I ) THEN
+               DO 40 K = N32, N
+                  TEMP = A( I, K )
+                  A( I, K ) = A( IP, K )
+                  A( IP, K ) = TEMP
+   40          CONTINUE
+            END IF
+            IX = IX + INCX
+   50    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLASWP
+*
+      END
diff --git a/src/lib/lapack/zlatdf.f b/src/lib/lapack/zlatdf.f
new file mode 100644
index 00000000..d637b8f1
--- /dev/null
+++ b/src/lib/lapack/zlatdf.f
@@ -0,0 +1,241 @@
+      SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
+     $                   JPIV )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IJOB, LDZ, N
+      DOUBLE PRECISION   RDSCAL, RDSUM
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IPIV( * ), JPIV( * )
+      COMPLEX*16         RHS( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATDF computes the contribution to the reciprocal Dif-estimate
+*  by solving for x in Z * x = b, where b is chosen such that the norm
+*  of x is as large as possible. It is assumed that LU decomposition
+*  of Z has been computed by ZGETC2. On entry RHS = f holds the
+*  contribution from earlier solved sub-systems, and on return RHS = x.
+*
+*  The factorization of Z returned by ZGETC2 has the form
+*  Z = P * L * U * Q, where P and Q are permutation matrices. L is lower
+*  triangular with unit diagonal elements and U is upper triangular.
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) INTEGER
+*          IJOB = 2: First compute an approximative null-vector e
+*              of Z using ZGECON, e is normalized and solve for
+*              Zx = +-e - f with the sign giving the greater value of
+*              2-norm(x).  About 5 times as expensive as Default.
+*          IJOB .ne. 2: Local look ahead strategy where
+*              all entries of the r.h.s. b is choosen as either +1 or
+*              -1.  Default.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Z.
+*
+*  Z       (input) DOUBLE PRECISION array, dimension (LDZ, N)
+*          On entry, the LU part of the factorization of the n-by-n
+*          matrix Z computed by ZGETC2:  Z = P * L * U * Q
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDA >= max(1, N).
+*
+*  RHS     (input/output) DOUBLE PRECISION array, dimension (N).
+*          On entry, RHS contains contributions from other subsystems.
+*          On exit, RHS contains the solution of the subsystem with
+*          entries according to the value of IJOB (see above).
+*
+*  RDSUM   (input/output) DOUBLE PRECISION
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by ZTGSYL, where the
+*          scaling factor RDSCAL (see below) has been factored out.
+*          On exit, the corresponding sum of squares updated with the
+*          contributions from the current sub-system.
+*          If TRANS = 'T' RDSUM is not touched.
+*          NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.
+*
+*  RDSCAL  (input/output) DOUBLE PRECISION
+*          On entry, scaling factor used to prevent overflow in RDSUM.
+*          On exit, RDSCAL is updated w.r.t. the current contributions
+*          in RDSUM.
+*          If TRANS = 'T', RDSCAL is not touched.
+*          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
+*          ZTGSYL.
+*
+*  IPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= i <= N, row i of the
+*          matrix has been interchanged with row IPIV(i).
+*
+*  JPIV    (input) INTEGER array, dimension (N).
+*          The pivot indices; for 1 <= j <= N, column j of the
+*          matrix has been interchanged with column JPIV(j).
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  This routine is a further developed implementation of algorithm
+*  BSOLVE in [1] using complete pivoting in the LU factorization.
+*
+*   [1]   Bo Kagstrom and Lars Westin,
+*         Generalized Schur Methods with Condition Estimators for
+*         Solving the Generalized Sylvester Equation, IEEE Transactions
+*         on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
+*
+*   [2]   Peter Poromaa,
+*         On Efficient and Robust Estimators for the Separation
+*         between two Regular Matrix Pairs with Applications in
+*         Condition Estimation. Report UMINF-95.05, Department of
+*         Computing Science, Umea University, S-901 87 Umea, Sweden,
+*         1995.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            MAXDIM
+      PARAMETER          ( MAXDIM = 2 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, INFO, J, K
+      DOUBLE PRECISION   RTEMP, SCALE, SMINU, SPLUS
+      COMPLEX*16         BM, BP, PMONE, TEMP
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   RWORK( MAXDIM )
+      COMPLEX*16         WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZCOPY, ZGECON, ZGESC2, ZLASSQ, ZLASWP,
+     $                   ZSCAL
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DZASUM
+      COMPLEX*16         ZDOTC
+      EXTERNAL           DZASUM, ZDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      IF( IJOB.NE.2 ) THEN
+*
+*        Apply permutations IPIV to RHS
+*
+         CALL ZLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
+*
+*        Solve for L-part choosing RHS either to +1 or -1.
+*
+         PMONE = -CONE
+         DO 10 J = 1, N - 1
+            BP = RHS( J ) + CONE
+            BM = RHS( J ) - CONE
+            SPLUS = ONE
+*
+*           Lockahead for L- part RHS(1:N-1) = +-1
+*           SPLUS and SMIN computed more efficiently than in BSOLVE[1].
+*
+            SPLUS = SPLUS + DBLE( ZDOTC( N-J, Z( J+1, J ), 1, Z( J+1,
+     $              J ), 1 ) )
+            SMINU = DBLE( ZDOTC( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 ) )
+            SPLUS = SPLUS*DBLE( RHS( J ) )
+            IF( SPLUS.GT.SMINU ) THEN
+               RHS( J ) = BP
+            ELSE IF( SMINU.GT.SPLUS ) THEN
+               RHS( J ) = BM
+            ELSE
+*
+*              In this case the updating sums are equal and we can
+*              choose RHS(J) +1 or -1. The first time this happens we
+*              choose -1, thereafter +1. This is a simple way to get
+*              good estimates of matrices like Byers well-known example
+*              (see [1]). (Not done in BSOLVE.)
+*
+               RHS( J ) = RHS( J ) + PMONE
+               PMONE = CONE
+            END IF
+*
+*           Compute the remaining r.h.s.
+*
+            TEMP = -RHS( J )
+            CALL ZAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+   10    CONTINUE
+*
+*        Solve for U- part, lockahead for RHS(N) = +-1. This is not done
+*        In BSOLVE and will hopefully give us a better estimate because
+*        any ill-conditioning of the original matrix is transfered to U
+*        and not to L. U(N, N) is an approximation to sigma_min(LU).
+*
+         CALL ZCOPY( N-1, RHS, 1, WORK, 1 )
+         WORK( N ) = RHS( N ) + CONE
+         RHS( N ) = RHS( N ) - CONE
+         SPLUS = ZERO
+         SMINU = ZERO
+         DO 30 I = N, 1, -1
+            TEMP = CONE / Z( I, I )
+            WORK( I ) = WORK( I )*TEMP
+            RHS( I ) = RHS( I )*TEMP
+            DO 20 K = I + 1, N
+               WORK( I ) = WORK( I ) - WORK( K )*( Z( I, K )*TEMP )
+               RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
+   20       CONTINUE
+            SPLUS = SPLUS + ABS( WORK( I ) )
+            SMINU = SMINU + ABS( RHS( I ) )
+   30    CONTINUE
+         IF( SPLUS.GT.SMINU )
+     $      CALL ZCOPY( N, WORK, 1, RHS, 1 )
+*
+*        Apply the permutations JPIV to the computed solution (RHS)
+*
+         CALL ZLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+*        Compute the sum of squares
+*
+         CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+         RETURN
+      END IF
+*
+*     ENTRY IJOB = 2
+*
+*     Compute approximate nullvector XM of Z
+*
+      CALL ZGECON( 'I', N, Z, LDZ, ONE, RTEMP, WORK, RWORK, INFO )
+      CALL ZCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+*     Compute RHS
+*
+      CALL ZLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+      TEMP = CONE / SQRT( ZDOTC( N, XM, 1, XM, 1 ) )
+      CALL ZSCAL( N, TEMP, XM, 1 )
+      CALL ZCOPY( N, XM, 1, XP, 1 )
+      CALL ZAXPY( N, CONE, RHS, 1, XP, 1 )
+      CALL ZAXPY( N, -CONE, XM, 1, RHS, 1 )
+      CALL ZGESC2( N, Z, LDZ, RHS, IPIV, JPIV, SCALE )
+      CALL ZGESC2( N, Z, LDZ, XP, IPIV, JPIV, SCALE )
+      IF( DZASUM( N, XP, 1 ).GT.DZASUM( N, RHS, 1 ) )
+     $   CALL ZCOPY( N, XP, 1, RHS, 1 )
+*
+*     Compute the sum of squares
+*
+      CALL ZLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+      RETURN
+*
+*     End of ZLATDF
+*
+      END
diff --git a/src/lib/lapack/zlatrd.f b/src/lib/lapack/zlatrd.f
new file mode 100644
index 00000000..5fef7b5c
--- /dev/null
+++ b/src/lib/lapack/zlatrd.f
@@ -0,0 +1,279 @@
+      SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            LDA, LDW, N, NB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   E( * )
+      COMPLEX*16         A( LDA, * ), TAU( * ), W( LDW, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
+*  Hermitian tridiagonal form by a unitary similarity
+*  transformation Q' * A * Q, and returns the matrices V and W which are
+*  needed to apply the transformation to the unreduced part of A.
+*
+*  If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
+*  matrix, of which the upper triangle is supplied;
+*  if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
+*  matrix, of which the lower triangle is supplied.
+*
+*  This is an auxiliary routine called by ZHETRD.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          Hermitian matrix A is stored:
+*          = 'U': Upper triangular
+*          = 'L': Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.
+*
+*  NB      (input) INTEGER
+*          The number of rows and columns to be reduced.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
+*          n-by-n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n-by-n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*          On exit:
+*          if UPLO = 'U', the last NB columns have been reduced to
+*            tridiagonal form, with the diagonal elements overwriting
+*            the diagonal elements of A; the elements above the diagonal
+*            with the array TAU, represent the unitary matrix Q as a
+*            product of elementary reflectors;
+*          if UPLO = 'L', the first NB columns have been reduced to
+*            tridiagonal form, with the diagonal elements overwriting
+*            the diagonal elements of A; the elements below the diagonal
+*            with the array TAU, represent the  unitary matrix Q as a
+*            product of elementary reflectors.
+*          See Further Details.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  E       (output) DOUBLE PRECISION array, dimension (N-1)
+*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
+*          elements of the last NB columns of the reduced matrix;
+*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
+*          the first NB columns of the reduced matrix.
+*
+*  TAU     (output) COMPLEX*16 array, dimension (N-1)
+*          The scalar factors of the elementary reflectors, stored in
+*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
+*          See Further Details.
+*
+*  W       (output) COMPLEX*16 array, dimension (LDW,NB)
+*          The n-by-nb matrix W required to update the unreduced part
+*          of A.
+*
+*  LDW     (input) INTEGER
+*          The leading dimension of the array W. LDW >= max(1,N).
+*
+*  Further Details
+*  ===============
+*
+*  If UPLO = 'U', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(n) H(n-1) . . . H(n-nb+1).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
+*  and tau in TAU(i-1).
+*
+*  If UPLO = 'L', the matrix Q is represented as a product of elementary
+*  reflectors
+*
+*     Q = H(1) H(2) . . . H(nb).
+*
+*  Each H(i) has the form
+*
+*     H(i) = I - tau * v * v'
+*
+*  where tau is a complex scalar, and v is a complex vector with
+*  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+*  and tau in TAU(i).
+*
+*  The elements of the vectors v together form the n-by-nb matrix V
+*  which is needed, with W, to apply the transformation to the unreduced
+*  part of the matrix, using a Hermitian rank-2k update of the form:
+*  A := A - V*W' - W*V'.
+*
+*  The contents of A on exit are illustrated by the following examples
+*  with n = 5 and nb = 2:
+*
+*  if UPLO = 'U':                       if UPLO = 'L':
+*
+*    (  a   a   a   v4  v5 )              (  d                  )
+*    (      a   a   v4  v5 )              (  1   d              )
+*    (          a   1   v5 )              (  v1  1   a          )
+*    (              d   1  )              (  v1  v2  a   a      )
+*    (                  d  )              (  v1  v2  a   a   a  )
+*
+*  where d denotes a diagonal element of the reduced matrix, a denotes
+*  an element of the original matrix that is unchanged, and vi denotes
+*  an element of the vector defining H(i).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE, HALF
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   HALF = ( 0.5D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, IW
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+      IF( LSAME( UPLO, 'U' ) ) THEN
+*
+*        Reduce last NB columns of upper triangle
+*
+         DO 10 I = N, N - NB + 1, -1
+            IW = I - N + NB
+            IF( I.LT.N ) THEN
+*
+*              Update A(1:i,i)
+*
+               A( I, I ) = DBLE( A( I, I ) )
+               CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
+               CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+     $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+               CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
+     $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
+               CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+               A( I, I ) = DBLE( A( I, I ) )
+            END IF
+            IF( I.GT.1 ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(1:i-2,i)
+*
+               ALPHA = A( I-1, I )
+               CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
+               E( I-1 ) = ALPHA
+               A( I-1, I ) = ONE
+*
+*              Compute W(1:i-1,i)
+*
+               CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+     $                     ZERO, W( 1, IW ), 1 )
+               IF( I.LT.N ) THEN
+                  CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
+     $                        W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
+     $                        W( I+1, IW ), 1 )
+                  CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+                  CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
+     $                        A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
+     $                        W( I+1, IW ), 1 )
+                  CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
+     $                        W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
+     $                        W( 1, IW ), 1 )
+               END IF
+               CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+               ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
+     $                 A( 1, I ), 1 )
+               CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
+            END IF
+*
+   10    CONTINUE
+      ELSE
+*
+*        Reduce first NB columns of lower triangle
+*
+         DO 20 I = 1, NB
+*
+*           Update A(i:n,i)
+*
+            A( I, I ) = DBLE( A( I, I ) )
+            CALL ZLACGV( I-1, W( I, 1 ), LDW )
+            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+     $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+            CALL ZLACGV( I-1, W( I, 1 ), LDW )
+            CALL ZLACGV( I-1, A( I, 1 ), LDA )
+            CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
+     $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
+            CALL ZLACGV( I-1, A( I, 1 ), LDA )
+            A( I, I ) = DBLE( A( I, I ) )
+            IF( I.LT.N ) THEN
+*
+*              Generate elementary reflector H(i) to annihilate
+*              A(i+2:n,i)
+*
+               ALPHA = A( I+1, I )
+               CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
+     $                      TAU( I ) )
+               E( I ) = ALPHA
+               A( I+1, I ) = ONE
+*
+*              Compute W(i+1:n,i)
+*
+               CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+     $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
+     $                     W( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+     $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
+     $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
+     $                     W( 1, I ), 1 )
+               CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+     $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+               CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+               ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
+     $                 A( I+1, I ), 1 )
+               CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+            END IF
+*
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZLATRD
+*
+      END
diff --git a/src/lib/lapack/zlatrs.f b/src/lib/lapack/zlatrs.f
new file mode 100644
index 00000000..7466096c
--- /dev/null
+++ b/src/lib/lapack/zlatrs.f
@@ -0,0 +1,879 @@
+      SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+     $                   CNORM, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, NORMIN, TRANS, UPLO
+      INTEGER            INFO, LDA, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   CNORM( * )
+      COMPLEX*16         A( LDA, * ), X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATRS solves one of the triangular systems
+*
+*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,
+*
+*  with scaling to prevent overflow.  Here A is an upper or lower
+*  triangular matrix, A**T denotes the transpose of A, A**H denotes the
+*  conjugate transpose of A, x and b are n-element vectors, and s is a
+*  scaling factor, usually less than or equal to 1, chosen so that the
+*  components of x will be less than the overflow threshold.  If the
+*  unscaled problem will not cause overflow, the Level 2 BLAS routine
+*  ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
+*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the matrix A is upper or lower triangular.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  TRANS   (input) CHARACTER*1
+*          Specifies the operation applied to A.
+*          = 'N':  Solve A * x = s*b     (No transpose)
+*          = 'T':  Solve A**T * x = s*b  (Transpose)
+*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)
+*
+*  DIAG    (input) CHARACTER*1
+*          Specifies whether or not the matrix A is unit triangular.
+*          = 'N':  Non-unit triangular
+*          = 'U':  Unit triangular
+*
+*  NORMIN  (input) CHARACTER*1
+*          Specifies whether CNORM has been set or not.
+*          = 'Y':  CNORM contains the column norms on entry
+*          = 'N':  CNORM is not set on entry.  On exit, the norms will
+*                  be computed and stored in CNORM.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,N)
+*          The triangular matrix A.  If UPLO = 'U', the leading n by n
+*          upper triangular part of the array A contains the upper
+*          triangular matrix, and the strictly lower triangular part of
+*          A is not referenced.  If UPLO = 'L', the leading n by n lower
+*          triangular part of the array A contains the lower triangular
+*          matrix, and the strictly upper triangular part of A is not
+*          referenced.  If DIAG = 'U', the diagonal elements of A are
+*          also not referenced and are assumed to be 1.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max (1,N).
+*
+*  X       (input/output) COMPLEX*16 array, dimension (N)
+*          On entry, the right hand side b of the triangular system.
+*          On exit, X is overwritten by the solution vector x.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          The scaling factor s for the triangular system
+*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.
+*          If SCALE = 0, the matrix A is singular or badly scaled, and
+*          the vector x is an exact or approximate solution to A*x = 0.
+*
+*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)
+*
+*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+*          contains the norm of the off-diagonal part of the j-th column
+*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal
+*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+*          must be greater than or equal to the 1-norm.
+*
+*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+*          returns the 1-norm of the offdiagonal part of the j-th column
+*          of A.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -k, the k-th argument had an illegal value
+*
+*  Further Details
+*  ======= =======
+*
+*  A rough bound on x is computed; if that is less than overflow, ZTRSV
+*  is called, otherwise, specific code is used which checks for possible
+*  overflow or divide-by-zero at every operation.
+*
+*  A columnwise scheme is used for solving A*x = b.  The basic algorithm
+*  if A is lower triangular is
+*
+*       x[1:n] := b[1:n]
+*       for j = 1, ..., n
+*            x(j) := x(j) / A(j,j)
+*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+*       end
+*
+*  Define bounds on the components of x after j iterations of the loop:
+*     M(j) = bound on x[1:j]
+*     G(j) = bound on x[j+1:n]
+*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+*  Then for iteration j+1 we have
+*     M(j+1) <= G(j) / | A(j+1,j+1) |
+*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+*  where CNORM(j+1) is greater than or equal to the infinity-norm of
+*  column j+1 of A, not counting the diagonal.  Hence
+*
+*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+*                  1<=i<=j
+*  and
+*
+*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+*                                   1<=i< j
+*
+*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the
+*  reciprocal of the largest M(j), j=1,..,n, is larger than
+*  max(underflow, 1/overflow).
+*
+*  The bound on x(j) is also used to determine when a step in the
+*  columnwise method can be performed without fear of overflow.  If
+*  the computed bound is greater than a large constant, x is scaled to
+*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+*  Similarly, a row-wise scheme is used to solve A**T *x = b  or
+*  A**H *x = b.  The basic algorithm for A upper triangular is
+*
+*       for j = 1, ..., n
+*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+*       end
+*
+*  We simultaneously compute two bounds
+*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+*       M(j) = bound on x(i), 1<=i<=j
+*
+*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+*  Then the bound on x(j) is
+*
+*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+*                      1<=i<=j
+*
+*  and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater
+*  than max(underflow, 1/overflow).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE, TWO
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
+     $                   TWO = 2.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN, NOUNIT, UPPER
+      INTEGER            I, IMAX, J, JFIRST, JINC, JLAST
+      DOUBLE PRECISION   BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL,
+     $                   XBND, XJ, XMAX
+      COMPLEX*16         CSUMJ, TJJS, USCAL, ZDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IDAMAX, IZAMAX
+      DOUBLE PRECISION   DLAMCH, DZASUM
+      COMPLEX*16         ZDOTC, ZDOTU, ZLADIV
+      EXTERNAL           LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC,
+     $                   ZDOTU, ZLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1, CABS2
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
+      CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) +
+     $                ABS( DIMAG( ZDUM ) / 2.D0 )
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      NOUNIT = LSAME( DIAG, 'N' )
+*
+*     Test the input parameters.
+*
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+     $         LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -3
+      ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+     $         LSAME( NORMIN, 'N' ) ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZLATRS', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine machine dependent parameters to control overflow.
+*
+      SMLNUM = DLAMCH( 'Safe minimum' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM / DLAMCH( 'Precision' )
+      BIGNUM = ONE / SMLNUM
+      SCALE = ONE
+*
+      IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+*        Compute the 1-norm of each column, not including the diagonal.
+*
+         IF( UPPER ) THEN
+*
+*           A is upper triangular.
+*
+            DO 10 J = 1, N
+               CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 )
+   10       CONTINUE
+         ELSE
+*
+*           A is lower triangular.
+*
+            DO 20 J = 1, N - 1
+               CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 )
+   20       CONTINUE
+            CNORM( N ) = ZERO
+         END IF
+      END IF
+*
+*     Scale the column norms by TSCAL if the maximum element in CNORM is
+*     greater than BIGNUM/2.
+*
+      IMAX = IDAMAX( N, CNORM, 1 )
+      TMAX = CNORM( IMAX )
+      IF( TMAX.LE.BIGNUM*HALF ) THEN
+         TSCAL = ONE
+      ELSE
+         TSCAL = HALF / ( SMLNUM*TMAX )
+         CALL DSCAL( N, TSCAL, CNORM, 1 )
+      END IF
+*
+*     Compute a bound on the computed solution vector to see if the
+*     Level 2 BLAS routine ZTRSV can be used.
+*
+      XMAX = ZERO
+      DO 30 J = 1, N
+         XMAX = MAX( XMAX, CABS2( X( J ) ) )
+   30 CONTINUE
+      XBND = XMAX
+*
+      IF( NOTRAN ) THEN
+*
+*        Compute the growth in A * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         ELSE
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 60
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = HALF / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 40 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 60
+*
+               TJJS = A( J, J )
+               TJJ = CABS1( TJJS )
+*
+               IF( TJJ.GE.SMLNUM ) THEN
+*
+*                 M(j) = G(j-1) / abs(A(j,j))
+*
+                  XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+               ELSE
+*
+*                 M(j) could overflow, set XBND to 0.
+*
+                  XBND = ZERO
+               END IF
+*
+               IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+*                 G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+                  GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+               ELSE
+*
+*                 G(j) could overflow, set GROW to 0.
+*
+                  GROW = ZERO
+               END IF
+   40       CONTINUE
+            GROW = XBND
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
+            DO 50 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 60
+*
+*              G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+               GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+   50       CONTINUE
+         END IF
+   60    CONTINUE
+*
+      ELSE
+*
+*        Compute the growth in A**T * x = b  or  A**H * x = b.
+*
+         IF( UPPER ) THEN
+            JFIRST = 1
+            JLAST = N
+            JINC = 1
+         ELSE
+            JFIRST = N
+            JLAST = 1
+            JINC = -1
+         END IF
+*
+         IF( TSCAL.NE.ONE ) THEN
+            GROW = ZERO
+            GO TO 90
+         END IF
+*
+         IF( NOUNIT ) THEN
+*
+*           A is non-unit triangular.
+*
+*           Compute GROW = 1/G(j) and XBND = 1/M(j).
+*           Initially, M(0) = max{x(i), i=1,...,n}.
+*
+            GROW = HALF / MAX( XBND, SMLNUM )
+            XBND = GROW
+            DO 70 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 90
+*
+*              G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+               XJ = ONE + CNORM( J )
+               GROW = MIN( GROW, XBND / XJ )
+*
+               TJJS = A( J, J )
+               TJJ = CABS1( TJJS )
+*
+               IF( TJJ.GE.SMLNUM ) THEN
+*
+*                 M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+                  IF( XJ.GT.TJJ )
+     $               XBND = XBND*( TJJ / XJ )
+               ELSE
+*
+*                 M(j) could overflow, set XBND to 0.
+*
+                  XBND = ZERO
+               END IF
+   70       CONTINUE
+            GROW = MIN( GROW, XBND )
+         ELSE
+*
+*           A is unit triangular.
+*
+*           Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+            GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) )
+            DO 80 J = JFIRST, JLAST, JINC
+*
+*              Exit the loop if the growth factor is too small.
+*
+               IF( GROW.LE.SMLNUM )
+     $            GO TO 90
+*
+*              G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+               XJ = ONE + CNORM( J )
+               GROW = GROW / XJ
+   80       CONTINUE
+         END IF
+   90    CONTINUE
+      END IF
+*
+      IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+*        Use the Level 2 BLAS solve if the reciprocal of the bound on
+*        elements of X is not too small.
+*
+         CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
+      ELSE
+*
+*        Use a Level 1 BLAS solve, scaling intermediate results.
+*
+         IF( XMAX.GT.BIGNUM*HALF ) THEN
+*
+*           Scale X so that its components are less than or equal to
+*           BIGNUM in absolute value.
+*
+            SCALE = ( BIGNUM*HALF ) / XMAX
+            CALL ZDSCAL( N, SCALE, X, 1 )
+            XMAX = BIGNUM
+         ELSE
+            XMAX = XMAX*TWO
+         END IF
+*
+         IF( NOTRAN ) THEN
+*
+*           Solve A * x = b
+*
+            DO 120 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+               XJ = CABS1( X( J ) )
+               IF( NOUNIT ) THEN
+                  TJJS = A( J, J )*TSCAL
+               ELSE
+                  TJJS = TSCAL
+                  IF( TSCAL.EQ.ONE )
+     $               GO TO 110
+               END IF
+               TJJ = CABS1( TJJS )
+               IF( TJJ.GT.SMLNUM ) THEN
+*
+*                    abs(A(j,j)) > SMLNUM:
+*
+                  IF( TJJ.LT.ONE ) THEN
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by 1/b(j).
+*
+                        REC = ONE / XJ
+                        CALL ZDSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                  END IF
+                  X( J ) = ZLADIV( X( J ), TJJS )
+                  XJ = CABS1( X( J ) )
+               ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                    0 < abs(A(j,j)) <= SMLNUM:
+*
+                  IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                       Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+*                       to avoid overflow when dividing by A(j,j).
+*
+                     REC = ( TJJ*BIGNUM ) / XJ
+                     IF( CNORM( J ).GT.ONE ) THEN
+*
+*                          Scale by 1/CNORM(j) to avoid overflow when
+*                          multiplying x(j) times column j.
+*
+                        REC = REC / CNORM( J )
+                     END IF
+                     CALL ZDSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+                  X( J ) = ZLADIV( X( J ), TJJS )
+                  XJ = CABS1( X( J ) )
+               ELSE
+*
+*                    A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                    scale = 0, and compute a solution to A*x = 0.
+*
+                  DO 100 I = 1, N
+                     X( I ) = ZERO
+  100             CONTINUE
+                  X( J ) = ONE
+                  XJ = ONE
+                  SCALE = ZERO
+                  XMAX = ZERO
+               END IF
+  110          CONTINUE
+*
+*              Scale x if necessary to avoid overflow when adding a
+*              multiple of column j of A.
+*
+               IF( XJ.GT.ONE ) THEN
+                  REC = ONE / XJ
+                  IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+*                    Scale x by 1/(2*abs(x(j))).
+*
+                     REC = REC*HALF
+                     CALL ZDSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                  END IF
+               ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+*                 Scale x by 1/2.
+*
+                  CALL ZDSCAL( N, HALF, X, 1 )
+                  SCALE = SCALE*HALF
+               END IF
+*
+               IF( UPPER ) THEN
+                  IF( J.GT.1 ) THEN
+*
+*                    Compute the update
+*                       x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+                     CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+     $                           1 )
+                     I = IZAMAX( J-1, X, 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+               ELSE
+                  IF( J.LT.N ) THEN
+*
+*                    Compute the update
+*                       x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+                     CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+     $                           X( J+1 ), 1 )
+                     I = J + IZAMAX( N-J, X( J+1 ), 1 )
+                     XMAX = CABS1( X( I ) )
+                  END IF
+               END IF
+  120       CONTINUE
+*
+         ELSE IF( LSAME( TRANS, 'T' ) ) THEN
+*
+*           Solve A**T * x = b
+*
+            DO 170 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = CABS1( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = A( J, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                  TJJ = CABS1( TJJS )
+                  IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                     REC = MIN( ONE, REC*TJJ )
+                     USCAL = ZLADIV( USCAL, TJJS )
+                  END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL ZDSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call ZDOTU to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 130 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
+  130                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 140 I = J + 1, N
+                        CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I )
+  140                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
+*
+*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - CSUMJ
+                  XJ = CABS1( X( J ) )
+                  IF( NOUNIT ) THEN
+                     TJJS = A( J, J )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 160
+                  END IF
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                  TJJ = CABS1( TJJS )
+                  IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                     IF( TJJ.LT.ONE ) THEN
+                        IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                           REC = ONE / XJ
+                           CALL ZDSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = ZLADIV( X( J ), TJJS )
+                  ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                       0 < abs(A(j,j)) <= SMLNUM:
+*
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+                        REC = ( TJJ*BIGNUM ) / XJ
+                        CALL ZDSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = ZLADIV( X( J ), TJJS )
+                  ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0 and compute a solution to A**T *x = 0.
+*
+                     DO 150 I = 1, N
+                        X( I ) = ZERO
+  150                CONTINUE
+                     X( J ) = ONE
+                     SCALE = ZERO
+                     XMAX = ZERO
+                  END IF
+  160             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  170       CONTINUE
+*
+         ELSE
+*
+*           Solve A**H * x = b
+*
+            DO 220 J = JFIRST, JLAST, JINC
+*
+*              Compute x(j) = b(j) - sum A(k,j)*x(k).
+*                                    k<>j
+*
+               XJ = CABS1( X( J ) )
+               USCAL = TSCAL
+               REC = ONE / MAX( XMAX, ONE )
+               IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+*                 If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+                  REC = REC*HALF
+                  IF( NOUNIT ) THEN
+                     TJJS = DCONJG( A( J, J ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                  END IF
+                  TJJ = CABS1( TJJS )
+                  IF( TJJ.GT.ONE ) THEN
+*
+*                       Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+                     REC = MIN( ONE, REC*TJJ )
+                     USCAL = ZLADIV( USCAL, TJJS )
+                  END IF
+                  IF( REC.LT.ONE ) THEN
+                     CALL ZDSCAL( N, REC, X, 1 )
+                     SCALE = SCALE*REC
+                     XMAX = XMAX*REC
+                  END IF
+               END IF
+*
+               CSUMJ = ZERO
+               IF( USCAL.EQ.DCMPLX( ONE ) ) THEN
+*
+*                 If the scaling needed for A in the dot product is 1,
+*                 call ZDOTC to perform the dot product.
+*
+                  IF( UPPER ) THEN
+                     CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 )
+                  ELSE IF( J.LT.N ) THEN
+                     CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
+                  END IF
+               ELSE
+*
+*                 Otherwise, use in-line code for the dot product.
+*
+                  IF( UPPER ) THEN
+                     DO 180 I = 1, J - 1
+                        CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
+     $                          X( I )
+  180                CONTINUE
+                  ELSE IF( J.LT.N ) THEN
+                     DO 190 I = J + 1, N
+                        CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )*
+     $                          X( I )
+  190                CONTINUE
+                  END IF
+               END IF
+*
+               IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN
+*
+*                 Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j)
+*                 was not used to scale the dotproduct.
+*
+                  X( J ) = X( J ) - CSUMJ
+                  XJ = CABS1( X( J ) )
+                  IF( NOUNIT ) THEN
+                     TJJS = DCONJG( A( J, J ) )*TSCAL
+                  ELSE
+                     TJJS = TSCAL
+                     IF( TSCAL.EQ.ONE )
+     $                  GO TO 210
+                  END IF
+*
+*                    Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+                  TJJ = CABS1( TJJS )
+                  IF( TJJ.GT.SMLNUM ) THEN
+*
+*                       abs(A(j,j)) > SMLNUM:
+*
+                     IF( TJJ.LT.ONE ) THEN
+                        IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                             Scale X by 1/abs(x(j)).
+*
+                           REC = ONE / XJ
+                           CALL ZDSCAL( N, REC, X, 1 )
+                           SCALE = SCALE*REC
+                           XMAX = XMAX*REC
+                        END IF
+                     END IF
+                     X( J ) = ZLADIV( X( J ), TJJS )
+                  ELSE IF( TJJ.GT.ZERO ) THEN
+*
+*                       0 < abs(A(j,j)) <= SMLNUM:
+*
+                     IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+*                          Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+                        REC = ( TJJ*BIGNUM ) / XJ
+                        CALL ZDSCAL( N, REC, X, 1 )
+                        SCALE = SCALE*REC
+                        XMAX = XMAX*REC
+                     END IF
+                     X( J ) = ZLADIV( X( J ), TJJS )
+                  ELSE
+*
+*                       A(j,j) = 0:  Set x(1:n) = 0, x(j) = 1, and
+*                       scale = 0 and compute a solution to A**H *x = 0.
+*
+                     DO 200 I = 1, N
+                        X( I ) = ZERO
+  200                CONTINUE
+                     X( J ) = ONE
+                     SCALE = ZERO
+                     XMAX = ZERO
+                  END IF
+  210             CONTINUE
+               ELSE
+*
+*                 Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot
+*                 product has already been divided by 1/A(j,j).
+*
+                  X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ
+               END IF
+               XMAX = MAX( XMAX, CABS1( X( J ) ) )
+  220       CONTINUE
+         END IF
+         SCALE = SCALE / TSCAL
+      END IF
+*
+*     Scale the column norms by 1/TSCAL for return.
+*
+      IF( TSCAL.NE.ONE ) THEN
+         CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+      END IF
+*
+      RETURN
+*
+*     End of ZLATRS
+*
+      END
diff --git a/src/lib/lapack/zlatrz.f b/src/lib/lapack/zlatrz.f
new file mode 100644
index 00000000..c1c7aab3
--- /dev/null
+++ b/src/lib/lapack/zlatrz.f
@@ -0,0 +1,133 @@
+      SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            L, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix
+*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z by means
+*  of unitary transformations, where  Z is an (M+L)-by-(M+L) unitary
+*  matrix and, R and A1 are M-by-M upper triangular matrices.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing the
+*          meaningful part of the Householder vectors. N-M >= L >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the leading M-by-N upper trapezoidal part of the
+*          array A must contain the matrix to be factorized.
+*          On exit, the leading M-by-M upper triangular part of A
+*          contains the upper triangular matrix R, and elements N-L+1 to
+*          N of the first M rows of A, with the array TAU, represent the
+*          unitary matrix Z as a product of M elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (M)
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The factorization is obtained by Householder's method.  The kth
+*  transformation matrix, Z( k ), which is used to introduce zeros into
+*  the ( m - k + 1 )th row of A, is given in the form
+*
+*     Z( k ) = ( I     0   ),
+*              ( 0  T( k ) )
+*
+*  where
+*
+*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
+*                                                 (   0    )
+*                                                 ( z( k ) )
+*
+*  tau is a scalar and z( k ) is an l element vector. tau and z( k )
+*  are chosen to annihilate the elements of the kth row of A2.
+*
+*  The scalar tau is returned in the kth element of TAU and the vector
+*  u( k ) in the kth row of A2, such that the elements of z( k ) are
+*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
+*  the upper triangular part of A1.
+*
+*  Z is given by
+*
+*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I
+      COMPLEX*16         ALPHA
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLACGV, ZLARFG, ZLARZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      DO 20 I = M, 1, -1
+*
+*        Generate elementary reflector H(i) to annihilate
+*        [ A(i,i) A(i,n-l+1:n) ]
+*
+         CALL ZLACGV( L, A( I, N-L+1 ), LDA )
+         ALPHA = DCONJG( A( I, I ) )
+         CALL ZLARFG( L+1, ALPHA, A( I, N-L+1 ), LDA, TAU( I ) )
+         TAU( I ) = DCONJG( TAU( I ) )
+*
+*        Apply H(i) to A(1:i-1,i:n) from the right
+*
+         CALL ZLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
+     $               DCONJG( TAU( I ) ), A( 1, I ), LDA, WORK )
+         A( I, I ) = DCONJG( ALPHA )
+*
+   20 CONTINUE
+*
+      RETURN
+*
+*     End of ZLATRZ
+*
+      END
diff --git a/src/lib/lapack/zpotf2.f b/src/lib/lapack/zpotf2.f
new file mode 100644
index 00000000..ca9df447
--- /dev/null
+++ b/src/lib/lapack/zpotf2.f
@@ -0,0 +1,174 @@
+      SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOTF2 computes the Cholesky factorization of a complex Hermitian
+*  positive definite matrix A.
+*
+*  The factorization has the form
+*     A = U' * U ,  if UPLO = 'U', or
+*     A = L  * L',  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the upper or lower triangular part of the
+*          Hermitian matrix A is stored.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
+*          n by n upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U'*U  or A = L*L'.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*          > 0: if INFO = k, the leading minor of order k is not
+*               positive definite, and the factorization could not be
+*               completed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+      COMPLEX*16         CONE
+      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J
+      DOUBLE PRECISION   AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      COMPLEX*16         ZDOTC
+      EXTERNAL           LSAME, ZDOTC
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZDSCAL, ZGEMV, ZLACGV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOTF2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( UPPER ) THEN
+*
+*        Compute the Cholesky factorization A = U'*U.
+*
+         DO 10 J = 1, N
+*
+*           Compute U(J,J) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1,
+     $            A( 1, J ), 1 )
+            IF( AJJ.LE.ZERO ) THEN
+               A( J, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            A( J, J ) = AJJ
+*
+*           Compute elements J+1:N of row J.
+*
+            IF( J.LT.N ) THEN
+               CALL ZLACGV( J-1, A( 1, J ), 1 )
+               CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ),
+     $                     LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA )
+               CALL ZLACGV( J-1, A( 1, J ), 1 )
+               CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
+            END IF
+   10    CONTINUE
+      ELSE
+*
+*        Compute the Cholesky factorization A = L*L'.
+*
+         DO 20 J = 1, N
+*
+*           Compute L(J,J) and test for non-positive-definiteness.
+*
+            AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA,
+     $            A( J, 1 ), LDA )
+            IF( AJJ.LE.ZERO ) THEN
+               A( J, J ) = AJJ
+               GO TO 30
+            END IF
+            AJJ = SQRT( AJJ )
+            A( J, J ) = AJJ
+*
+*           Compute elements J+1:N of column J.
+*
+            IF( J.LT.N ) THEN
+               CALL ZLACGV( J-1, A( J, 1 ), LDA )
+               CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ),
+     $                     LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 )
+               CALL ZLACGV( J-1, A( J, 1 ), LDA )
+               CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = J
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of ZPOTF2
+*
+      END
diff --git a/src/lib/lapack/zpotrf.f b/src/lib/lapack/zpotrf.f
new file mode 100644
index 00000000..86772608
--- /dev/null
+++ b/src/lib/lapack/zpotrf.f
@@ -0,0 +1,186 @@
+      SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZPOTRF computes the Cholesky factorization of a complex Hermitian
+*  positive definite matrix A.
+*
+*  The factorization has the form
+*     A = U**H * U,  if UPLO = 'U', or
+*     A = L  * L**H,  if UPLO = 'L',
+*  where U is an upper triangular matrix and L is lower triangular.
+*
+*  This is the block version of the algorithm, calling Level 3 BLAS.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  Upper triangle of A is stored;
+*          = 'L':  Lower triangle of A is stored.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
+*          N-by-N upper triangular part of A contains the upper
+*          triangular part of the matrix A, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of A contains the lower
+*          triangular part of the matrix A, and the strictly upper
+*          triangular part of A is not referenced.
+*
+*          On exit, if INFO = 0, the factor U or L from the Cholesky
+*          factorization A = U**H*U or A = L*L**H.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  if INFO = i, the leading minor of order i is not
+*                positive definite, and the factorization could not be
+*                completed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      COMPLEX*16         CONE
+      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            UPPER
+      INTEGER            J, JB, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZPOTRF', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code.
+*
+         CALL ZPOTF2( UPLO, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code.
+*
+         IF( UPPER ) THEN
+*
+*           Compute the Cholesky factorization A = U'*U.
+*
+            DO 10 J = 1, N, NB
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               JB = MIN( NB, N-J+1 )
+               CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1,
+     $                     -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA )
+               CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute the current block row.
+*
+                  CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB,
+     $                        N-J-JB+1, J-1, -CONE, A( 1, J ), LDA,
+     $                        A( 1, J+JB ), LDA, CONE, A( J, J+JB ),
+     $                        LDA )
+                  CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose',
+     $                        'Non-unit', JB, N-J-JB+1, CONE, A( J, J ),
+     $                        LDA, A( J, J+JB ), LDA )
+               END IF
+   10       CONTINUE
+*
+         ELSE
+*
+*           Compute the Cholesky factorization A = L*L'.
+*
+            DO 20 J = 1, N, NB
+*
+*              Update and factorize the current diagonal block and test
+*              for non-positive-definiteness.
+*
+               JB = MIN( NB, N-J+1 )
+               CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE,
+     $                     A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+               CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+               IF( INFO.NE.0 )
+     $            GO TO 30
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute the current block column.
+*
+                  CALL ZGEMM( 'No transpose', 'Conjugate transpose',
+     $                        N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ),
+     $                        LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ),
+     $                        LDA )
+                  CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose',
+     $                        'Non-unit', N-J-JB+1, JB, CONE, A( J, J ),
+     $                        LDA, A( J+JB, J ), LDA )
+               END IF
+   20       CONTINUE
+         END IF
+      END IF
+      GO TO 40
+*
+   30 CONTINUE
+      INFO = INFO + J - 1
+*
+   40 CONTINUE
+      RETURN
+*
+*     End of ZPOTRF
+*
+      END
diff --git a/src/lib/lapack/zrot.f b/src/lib/lapack/zrot.f
new file mode 100644
index 00000000..9c548e23
--- /dev/null
+++ b/src/lib/lapack/zrot.f
@@ -0,0 +1,91 @@
+      SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, INCY, N
+      DOUBLE PRECISION   C
+      COMPLEX*16         S
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         CX( * ), CY( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZROT   applies a plane rotation, where the cos (C) is real and the
+*  sin (S) is complex, and the vectors CX and CY are complex.
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The number of elements in the vectors CX and CY.
+*
+*  CX      (input/output) COMPLEX*16 array, dimension (N)
+*          On input, the vector X.
+*          On output, CX is overwritten with C*X + S*Y.
+*
+*  INCX    (input) INTEGER
+*          The increment between successive values of CY.  INCX <> 0.
+*
+*  CY      (input/output) COMPLEX*16 array, dimension (N)
+*          On input, the vector Y.
+*          On output, CY is overwritten with -CONJG(S)*X + C*Y.
+*
+*  INCY    (input) INTEGER
+*          The increment between successive values of CY.  INCX <> 0.
+*
+*  C       (input) DOUBLE PRECISION
+*  S       (input) COMPLEX*16
+*          C and S define a rotation
+*             [  C          S  ]
+*             [ -conjg(S)   C  ]
+*          where C*C + S*CONJG(S) = 1.0.
+*
+* =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            I, IX, IY
+      COMPLEX*16         STEMP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 )
+     $   RETURN
+      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
+     $   GO TO 20
+*
+*     Code for unequal increments or equal increments not equal to 1
+*
+      IX = 1
+      IY = 1
+      IF( INCX.LT.0 )
+     $   IX = ( -N+1 )*INCX + 1
+      IF( INCY.LT.0 )
+     $   IY = ( -N+1 )*INCY + 1
+      DO 10 I = 1, N
+         STEMP = C*CX( IX ) + S*CY( IY )
+         CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX )
+         CX( IX ) = STEMP
+         IX = IX + INCX
+         IY = IY + INCY
+   10 CONTINUE
+      RETURN
+*
+*     Code for both increments equal to 1
+*
+   20 CONTINUE
+      DO 30 I = 1, N
+         STEMP = C*CX( I ) + S*CY( I )
+         CY( I ) = C*CY( I ) - DCONJG( S )*CX( I )
+         CX( I ) = STEMP
+   30 CONTINUE
+      RETURN
+      END
diff --git a/src/lib/lapack/zsteqr.f b/src/lib/lapack/zsteqr.f
new file mode 100644
index 00000000..a72fdd96
--- /dev/null
+++ b/src/lib/lapack/zsteqr.f
@@ -0,0 +1,503 @@
+      SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPZ
+      INTEGER            INFO, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION   D( * ), E( * ), WORK( * )
+      COMPLEX*16         Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
+*  symmetric tridiagonal matrix using the implicit QL or QR method.
+*  The eigenvectors of a full or band complex Hermitian matrix can also
+*  be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
+*  matrix to tridiagonal form.
+*
+*  Arguments
+*  =========
+*
+*  COMPZ   (input) CHARACTER*1
+*          = 'N':  Compute eigenvalues only.
+*          = 'V':  Compute eigenvalues and eigenvectors of the original
+*                  Hermitian matrix.  On entry, Z must contain the
+*                  unitary matrix used to reduce the original matrix
+*                  to tridiagonal form.
+*          = 'I':  Compute eigenvalues and eigenvectors of the
+*                  tridiagonal matrix.  Z is initialized to the identity
+*                  matrix.
+*
+*  N       (input) INTEGER
+*          The order of the matrix.  N >= 0.
+*
+*  D       (input/output) DOUBLE PRECISION array, dimension (N)
+*          On entry, the diagonal elements of the tridiagonal matrix.
+*          On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)
+*          On entry, the (n-1) subdiagonal elements of the tridiagonal
+*          matrix.
+*          On exit, E has been destroyed.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)
+*          On entry, if  COMPZ = 'V', then Z contains the unitary
+*          matrix used in the reduction to tridiagonal form.
+*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
+*          orthonormal eigenvectors of the original Hermitian matrix,
+*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+*          of the symmetric tridiagonal matrix.
+*          If COMPZ = 'N', then Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z.  LDZ >= 1, and if
+*          eigenvectors are desired, then  LDZ >= max(1,N).
+*
+*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
+*          If COMPZ = 'N', then WORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*          > 0:  the algorithm has failed to find all the eigenvalues in
+*                a total of 30*N iterations; if INFO = i, then i
+*                elements of E have not converged to zero; on exit, D
+*                and E contain the elements of a symmetric tridiagonal
+*                matrix which is unitarily similar to the original
+*                matrix.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
+      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+     $                   THREE = 3.0D0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D0, 0.0D0 ),
+     $                   CONE = ( 1.0D0, 0.0D0 ) )
+      INTEGER            MAXIT
+      PARAMETER          ( MAXIT = 30 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
+     $                   LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
+     $                   NM1, NMAXIT
+      DOUBLE PRECISION   ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+     $                   S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, DLANST, DLAPY2
+      EXTERNAL           LSAME, DLAMCH, DLANST, DLAPY2
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLAE2, DLAEV2, DLARTG, DLASCL, DLASRT, XERBLA,
+     $                   ZLASET, ZLASR, ZSWAP
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+*
+      IF( LSAME( COMPZ, 'N' ) ) THEN
+         ICOMPZ = 0
+      ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+         ICOMPZ = 1
+      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+         ICOMPZ = 2
+      ELSE
+         ICOMPZ = -1
+      END IF
+      IF( ICOMPZ.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+     $         N ) ) ) THEN
+         INFO = -6
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZSTEQR', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+      IF( N.EQ.1 ) THEN
+         IF( ICOMPZ.EQ.2 )
+     $      Z( 1, 1 ) = CONE
+         RETURN
+      END IF
+*
+*     Determine the unit roundoff and over/underflow thresholds.
+*
+      EPS = DLAMCH( 'E' )
+      EPS2 = EPS**2
+      SAFMIN = DLAMCH( 'S' )
+      SAFMAX = ONE / SAFMIN
+      SSFMAX = SQRT( SAFMAX ) / THREE
+      SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+*     Compute the eigenvalues and eigenvectors of the tridiagonal
+*     matrix.
+*
+      IF( ICOMPZ.EQ.2 )
+     $   CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDZ )
+*
+      NMAXIT = N*MAXIT
+      JTOT = 0
+*
+*     Determine where the matrix splits and choose QL or QR iteration
+*     for each block, according to whether top or bottom diagonal
+*     element is smaller.
+*
+      L1 = 1
+      NM1 = N - 1
+*
+   10 CONTINUE
+      IF( L1.GT.N )
+     $   GO TO 160
+      IF( L1.GT.1 )
+     $   E( L1-1 ) = ZERO
+      IF( L1.LE.NM1 ) THEN
+         DO 20 M = L1, NM1
+            TST = ABS( E( M ) )
+            IF( TST.EQ.ZERO )
+     $         GO TO 30
+            IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+     $          1 ) ) ) )*EPS ) THEN
+               E( M ) = ZERO
+               GO TO 30
+            END IF
+   20    CONTINUE
+      END IF
+      M = N
+*
+   30 CONTINUE
+      L = L1
+      LSV = L
+      LEND = M
+      LENDSV = LEND
+      L1 = M + 1
+      IF( LEND.EQ.L )
+     $   GO TO 10
+*
+*     Scale submatrix in rows and columns L to LEND
+*
+      ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
+      ISCALE = 0
+      IF( ANORM.EQ.ZERO )
+     $   GO TO 10
+      IF( ANORM.GT.SSFMAX ) THEN
+         ISCALE = 1
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+     $                INFO )
+      ELSE IF( ANORM.LT.SSFMIN ) THEN
+         ISCALE = 2
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+     $                INFO )
+         CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+     $                INFO )
+      END IF
+*
+*     Choose between QL and QR iteration
+*
+      IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+         LEND = LSV
+         L = LENDSV
+      END IF
+*
+      IF( LEND.GT.L ) THEN
+*
+*        QL Iteration
+*
+*        Look for small subdiagonal element.
+*
+   40    CONTINUE
+         IF( L.NE.LEND ) THEN
+            LENDM1 = LEND - 1
+            DO 50 M = L, LENDM1
+               TST = ABS( E( M ) )**2
+               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
+     $             SAFMIN )GO TO 60
+   50       CONTINUE
+         END IF
+*
+         M = LEND
+*
+   60    CONTINUE
+         IF( M.LT.LEND )
+     $      E( M ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 80
+*
+*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L+1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+               WORK( L ) = C
+               WORK( N-1+L ) = S
+               CALL ZLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+     $                     WORK( N-1+L ), Z( 1, L ), LDZ )
+            ELSE
+               CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
+            END IF
+            D( L ) = RT1
+            D( L+1 ) = RT2
+            E( L ) = ZERO
+            L = L + 2
+            IF( L.LE.LEND )
+     $         GO TO 40
+            GO TO 140
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 140
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         G = ( D( L+1 )-P ) / ( TWO*E( L ) )
+         R = DLAPY2( G, ONE )
+         G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
+*
+         S = ONE
+         C = ONE
+         P = ZERO
+*
+*        Inner loop
+*
+         MM1 = M - 1
+         DO 70 I = MM1, L, -1
+            F = S*E( I )
+            B = C*E( I )
+            CALL DLARTG( G, F, C, S, R )
+            IF( I.NE.M-1 )
+     $         E( I+1 ) = R
+            G = D( I+1 ) - P
+            R = ( D( I )-G )*S + TWO*C*B
+            P = S*R
+            D( I+1 ) = G + P
+            G = C*R - B
+*
+*           If eigenvectors are desired, then save rotations.
+*
+            IF( ICOMPZ.GT.0 ) THEN
+               WORK( I ) = C
+               WORK( N-1+I ) = -S
+            END IF
+*
+   70    CONTINUE
+*
+*        If eigenvectors are desired, then apply saved rotations.
+*
+         IF( ICOMPZ.GT.0 ) THEN
+            MM = M - L + 1
+            CALL ZLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
+     $                  Z( 1, L ), LDZ )
+         END IF
+*
+         D( L ) = D( L ) - P
+         E( L ) = G
+         GO TO 40
+*
+*        Eigenvalue found.
+*
+   80    CONTINUE
+         D( L ) = P
+*
+         L = L + 1
+         IF( L.LE.LEND )
+     $      GO TO 40
+         GO TO 140
+*
+      ELSE
+*
+*        QR Iteration
+*
+*        Look for small superdiagonal element.
+*
+   90    CONTINUE
+         IF( L.NE.LEND ) THEN
+            LENDP1 = LEND + 1
+            DO 100 M = L, LENDP1, -1
+               TST = ABS( E( M-1 ) )**2
+               IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
+     $             SAFMIN )GO TO 110
+  100       CONTINUE
+         END IF
+*
+         M = LEND
+*
+  110    CONTINUE
+         IF( M.GT.LEND )
+     $      E( M-1 ) = ZERO
+         P = D( L )
+         IF( M.EQ.L )
+     $      GO TO 130
+*
+*        If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+*        to compute its eigensystem.
+*
+         IF( M.EQ.L-1 ) THEN
+            IF( ICOMPZ.GT.0 ) THEN
+               CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+               WORK( M ) = C
+               WORK( N-1+M ) = S
+               CALL ZLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+     $                     WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+            ELSE
+               CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
+            END IF
+            D( L-1 ) = RT1
+            D( L ) = RT2
+            E( L-1 ) = ZERO
+            L = L - 2
+            IF( L.GE.LEND )
+     $         GO TO 90
+            GO TO 140
+         END IF
+*
+         IF( JTOT.EQ.NMAXIT )
+     $      GO TO 140
+         JTOT = JTOT + 1
+*
+*        Form shift.
+*
+         G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
+         R = DLAPY2( G, ONE )
+         G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
+*
+         S = ONE
+         C = ONE
+         P = ZERO
+*
+*        Inner loop
+*
+         LM1 = L - 1
+         DO 120 I = M, LM1
+            F = S*E( I )
+            B = C*E( I )
+            CALL DLARTG( G, F, C, S, R )
+            IF( I.NE.M )
+     $         E( I-1 ) = R
+            G = D( I ) - P
+            R = ( D( I+1 )-G )*S + TWO*C*B
+            P = S*R
+            D( I ) = G + P
+            G = C*R - B
+*
+*           If eigenvectors are desired, then save rotations.
+*
+            IF( ICOMPZ.GT.0 ) THEN
+               WORK( I ) = C
+               WORK( N-1+I ) = S
+            END IF
+*
+  120    CONTINUE
+*
+*        If eigenvectors are desired, then apply saved rotations.
+*
+         IF( ICOMPZ.GT.0 ) THEN
+            MM = L - M + 1
+            CALL ZLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
+     $                  Z( 1, M ), LDZ )
+         END IF
+*
+         D( L ) = D( L ) - P
+         E( LM1 ) = G
+         GO TO 90
+*
+*        Eigenvalue found.
+*
+  130    CONTINUE
+         D( L ) = P
+*
+         L = L - 1
+         IF( L.GE.LEND )
+     $      GO TO 90
+         GO TO 140
+*
+      END IF
+*
+*     Undo scaling if necessary
+*
+  140 CONTINUE
+      IF( ISCALE.EQ.1 ) THEN
+         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      ELSE IF( ISCALE.EQ.2 ) THEN
+         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+     $                D( LSV ), N, INFO )
+         CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
+     $                N, INFO )
+      END IF
+*
+*     Check for no convergence to an eigenvalue after a total
+*     of N*MAXIT iterations.
+*
+      IF( JTOT.EQ.NMAXIT ) THEN
+         DO 150 I = 1, N - 1
+            IF( E( I ).NE.ZERO )
+     $         INFO = INFO + 1
+  150    CONTINUE
+         RETURN
+      END IF
+      GO TO 10
+*
+*     Order eigenvalues and eigenvectors.
+*
+  160 CONTINUE
+      IF( ICOMPZ.EQ.0 ) THEN
+*
+*        Use Quick Sort
+*
+         CALL DLASRT( 'I', N, D, INFO )
+*
+      ELSE
+*
+*        Use Selection Sort to minimize swaps of eigenvectors
+*
+         DO 180 II = 2, N
+            I = II - 1
+            K = I
+            P = D( I )
+            DO 170 J = II, N
+               IF( D( J ).LT.P ) THEN
+                  K = J
+                  P = D( J )
+               END IF
+  170       CONTINUE
+            IF( K.NE.I ) THEN
+               D( K ) = D( I )
+               D( I ) = P
+               CALL ZSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+            END IF
+  180    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZSTEQR
+*
+      END
diff --git a/src/lib/lapack/ztgevc.f b/src/lib/lapack/ztgevc.f
new file mode 100644
index 00000000..b8da962d
--- /dev/null
+++ b/src/lib/lapack/ztgevc.f
@@ -0,0 +1,633 @@
+      SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
+     $                   LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, SIDE
+      INTEGER            INFO, LDP, LDS, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+     $                   VR( LDVR, * ), WORK( * )
+*     ..
+*
+*
+*  Purpose
+*  =======
+*
+*  ZTGEVC computes some or all of the right and/or left eigenvectors of
+*  a pair of complex matrices (S,P), where S and P are upper triangular.
+*  Matrix pairs of this type are produced by the generalized Schur
+*  factorization of a complex matrix pair (A,B):
+*  
+*     A = Q*S*Z**H,  B = Q*P*Z**H
+*  
+*  as computed by ZGGHRD + ZHGEQZ.
+*  
+*  The right eigenvector x and the left eigenvector y of (S,P)
+*  corresponding to an eigenvalue w are defined by:
+*  
+*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,
+*  
+*  where y**H denotes the conjugate tranpose of y.
+*  The eigenvalues are not input to this routine, but are computed
+*  directly from the diagonal elements of S and P.
+*  
+*  This routine returns the matrices X and/or Y of right and left
+*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,
+*  where Z and Q are input matrices.
+*  If Q and Z are the unitary factors from the generalized Schur
+*  factorization of a matrix pair (A,B), then Z*X and Q*Y
+*  are the matrices of right and left eigenvectors of (A,B).
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R': compute right eigenvectors only;
+*          = 'L': compute left eigenvectors only;
+*          = 'B': compute both right and left eigenvectors.
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A': compute all right and/or left eigenvectors;
+*          = 'B': compute all right and/or left eigenvectors,
+*                 backtransformed by the matrices in VR and/or VL;
+*          = 'S': compute selected right and/or left eigenvectors,
+*                 specified by the logical array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY='S', SELECT specifies the eigenvectors to be
+*          computed.  The eigenvector corresponding to the j-th
+*          eigenvalue is computed if SELECT(j) = .TRUE..
+*          Not referenced if HOWMNY = 'A' or 'B'.
+*
+*  N       (input) INTEGER
+*          The order of the matrices S and P.  N >= 0.
+*
+*  S       (input) COMPLEX*16 array, dimension (LDS,N)
+*          The upper triangular matrix S from a generalized Schur
+*          factorization, as computed by ZHGEQZ.
+*
+*  LDS     (input) INTEGER
+*          The leading dimension of array S.  LDS >= max(1,N).
+*
+*  P       (input) COMPLEX*16 array, dimension (LDP,N)
+*          The upper triangular matrix P from a generalized Schur
+*          factorization, as computed by ZHGEQZ.  P must have real
+*          diagonal elements.
+*
+*  LDP     (input) INTEGER
+*          The leading dimension of array P.  LDP >= max(1,N).
+*
+*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)
+*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*          contain an N-by-N matrix Q (usually the unitary matrix Q
+*          of left Schur vectors returned by ZHGEQZ).
+*          On exit, if SIDE = 'L' or 'B', VL contains:
+*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
+*          if HOWMNY = 'B', the matrix Q*Y;
+*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
+*                      SELECT, stored consecutively in the columns of
+*                      VL, in the same order as their eigenvalues.
+*          Not referenced if SIDE = 'R'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of array VL.  LDVL >= 1, and if
+*          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
+*
+*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)
+*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*          contain an N-by-N matrix Q (usually the unitary matrix Z
+*          of right Schur vectors returned by ZHGEQZ).
+*          On exit, if SIDE = 'R' or 'B', VR contains:
+*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
+*          if HOWMNY = 'B', the matrix Z*X;
+*          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
+*                      SELECT, stored consecutively in the columns of
+*                      VR, in the same order as their eigenvalues.
+*          Not referenced if SIDE = 'L'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1, and if
+*          SIDE = 'R' or 'B', LDVR >= N.
+*
+*  MM      (input) INTEGER
+*          The number of columns in the arrays VL and/or VR. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of columns in the arrays VL and/or VR actually
+*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
+*          is set to N.  Each selected eigenvector occupies one column.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit.
+*          < 0:  if INFO = -i, the i-th argument had an illegal value.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            COMPL, COMPR, ILALL, ILBACK, ILBBAD, ILCOMP,
+     $                   LSA, LSB
+      INTEGER            I, IBEG, IEIG, IEND, IHWMNY, IM, ISIDE, ISRC,
+     $                   J, JE, JR
+      DOUBLE PRECISION   ACOEFA, ACOEFF, ANORM, ASCALE, BCOEFA, BIG,
+     $                   BIGNUM, BNORM, BSCALE, DMIN, SAFMIN, SBETA,
+     $                   SCALE, SMALL, TEMP, ULP, XMAX
+      COMPLEX*16         BCOEFF, CA, CB, D, SALPHA, SUM, SUMA, SUMB, X
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH
+      COMPLEX*16         ZLADIV
+      EXTERNAL           LSAME, DLAMCH, ZLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZGEMV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   ABS1
+*     ..
+*     .. Statement Function definitions ..
+      ABS1( X ) = ABS( DBLE( X ) ) + ABS( DIMAG( X ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test the input parameters
+*
+      IF( LSAME( HOWMNY, 'A' ) ) THEN
+         IHWMNY = 1
+         ILALL = .TRUE.
+         ILBACK = .FALSE.
+      ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
+         IHWMNY = 2
+         ILALL = .FALSE.
+         ILBACK = .FALSE.
+      ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
+         IHWMNY = 3
+         ILALL = .TRUE.
+         ILBACK = .TRUE.
+      ELSE
+         IHWMNY = -1
+      END IF
+*
+      IF( LSAME( SIDE, 'R' ) ) THEN
+         ISIDE = 1
+         COMPL = .FALSE.
+         COMPR = .TRUE.
+      ELSE IF( LSAME( SIDE, 'L' ) ) THEN
+         ISIDE = 2
+         COMPL = .TRUE.
+         COMPR = .FALSE.
+      ELSE IF( LSAME( SIDE, 'B' ) ) THEN
+         ISIDE = 3
+         COMPL = .TRUE.
+         COMPR = .TRUE.
+      ELSE
+         ISIDE = -1
+      END IF
+*
+      INFO = 0
+      IF( ISIDE.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( IHWMNY.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Count the number of eigenvectors
+*
+      IF( .NOT.ILALL ) THEN
+         IM = 0
+         DO 10 J = 1, N
+            IF( SELECT( J ) )
+     $         IM = IM + 1
+   10    CONTINUE
+      ELSE
+         IM = N
+      END IF
+*
+*     Check diagonal of B
+*
+      ILBBAD = .FALSE.
+      DO 20 J = 1, N
+         IF( DIMAG( P( J, J ) ).NE.ZERO )
+     $      ILBBAD = .TRUE.
+   20 CONTINUE
+*
+      IF( ILBBAD ) THEN
+         INFO = -7
+      ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
+         INFO = -10
+      ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
+         INFO = -12
+      ELSE IF( MM.LT.IM ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGEVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      M = IM
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Machine Constants
+*
+      SAFMIN = DLAMCH( 'Safe minimum' )
+      BIG = ONE / SAFMIN
+      CALL DLABAD( SAFMIN, BIG )
+      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+      SMALL = SAFMIN*N / ULP
+      BIG = ONE / SMALL
+      BIGNUM = ONE / ( SAFMIN*N )
+*
+*     Compute the 1-norm of each column of the strictly upper triangular
+*     part of A and B to check for possible overflow in the triangular
+*     solver.
+*
+      ANORM = ABS1( S( 1, 1 ) )
+      BNORM = ABS1( P( 1, 1 ) )
+      RWORK( 1 ) = ZERO
+      RWORK( N+1 ) = ZERO
+      DO 40 J = 2, N
+         RWORK( J ) = ZERO
+         RWORK( N+J ) = ZERO
+         DO 30 I = 1, J - 1
+            RWORK( J ) = RWORK( J ) + ABS1( S( I, J ) )
+            RWORK( N+J ) = RWORK( N+J ) + ABS1( P( I, J ) )
+   30    CONTINUE
+         ANORM = MAX( ANORM, RWORK( J )+ABS1( S( J, J ) ) )
+         BNORM = MAX( BNORM, RWORK( N+J )+ABS1( P( J, J ) ) )
+   40 CONTINUE
+*
+      ASCALE = ONE / MAX( ANORM, SAFMIN )
+      BSCALE = ONE / MAX( BNORM, SAFMIN )
+*
+*     Left eigenvectors
+*
+      IF( COMPL ) THEN
+         IEIG = 0
+*
+*        Main loop over eigenvalues
+*
+         DO 140 JE = 1, N
+            IF( ILALL ) THEN
+               ILCOMP = .TRUE.
+            ELSE
+               ILCOMP = SELECT( JE )
+            END IF
+            IF( ILCOMP ) THEN
+               IEIG = IEIG + 1
+*
+               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
+     $             ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
+*
+*                 Singular matrix pencil -- return unit eigenvector
+*
+                  DO 50 JR = 1, N
+                     VL( JR, IEIG ) = CZERO
+   50             CONTINUE
+                  VL( IEIG, IEIG ) = CONE
+                  GO TO 140
+               END IF
+*
+*              Non-singular eigenvalue:
+*              Compute coefficients  a  and  b  in
+*                   H
+*                 y  ( a A - b B ) = 0
+*
+               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
+     $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
+               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
+               ACOEFF = SBETA*ASCALE
+               BCOEFF = SALPHA*BSCALE
+*
+*              Scale to avoid underflow
+*
+               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
+               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
+     $               SMALL
+*
+               SCALE = ONE
+               IF( LSA )
+     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+               IF( LSB )
+     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
+     $                    MIN( BNORM, BIG ) )
+               IF( LSA .OR. LSB ) THEN
+                  SCALE = MIN( SCALE, ONE /
+     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
+     $                    ABS1( BCOEFF ) ) ) )
+                  IF( LSA ) THEN
+                     ACOEFF = ASCALE*( SCALE*SBETA )
+                  ELSE
+                     ACOEFF = SCALE*ACOEFF
+                  END IF
+                  IF( LSB ) THEN
+                     BCOEFF = BSCALE*( SCALE*SALPHA )
+                  ELSE
+                     BCOEFF = SCALE*BCOEFF
+                  END IF
+               END IF
+*
+               ACOEFA = ABS( ACOEFF )
+               BCOEFA = ABS1( BCOEFF )
+               XMAX = ONE
+               DO 60 JR = 1, N
+                  WORK( JR ) = CZERO
+   60          CONTINUE
+               WORK( JE ) = CONE
+               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+*                                              H
+*              Triangular solve of  (a A - b B)  y = 0
+*
+*                                      H
+*              (rowwise in  (a A - b B) , or columnwise in a A - b B)
+*
+               DO 100 J = JE + 1, N
+*
+*                 Compute
+*                       j-1
+*                 SUM = sum  conjg( a*S(k,j) - b*P(k,j) )*x(k)
+*                       k=je
+*                 (Scale if necessary)
+*
+                  TEMP = ONE / XMAX
+                  IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GT.BIGNUM*
+     $                TEMP ) THEN
+                     DO 70 JR = JE, J - 1
+                        WORK( JR ) = TEMP*WORK( JR )
+   70                CONTINUE
+                     XMAX = ONE
+                  END IF
+                  SUMA = CZERO
+                  SUMB = CZERO
+*
+                  DO 80 JR = JE, J - 1
+                     SUMA = SUMA + DCONJG( S( JR, J ) )*WORK( JR )
+                     SUMB = SUMB + DCONJG( P( JR, J ) )*WORK( JR )
+   80             CONTINUE
+                  SUM = ACOEFF*SUMA - DCONJG( BCOEFF )*SUMB
+*
+*                 Form x(j) = - SUM / conjg( a*S(j,j) - b*P(j,j) )
+*
+*                 with scaling and perturbation of the denominator
+*
+                  D = DCONJG( ACOEFF*S( J, J )-BCOEFF*P( J, J ) )
+                  IF( ABS1( D ).LE.DMIN )
+     $               D = DCMPLX( DMIN )
+*
+                  IF( ABS1( D ).LT.ONE ) THEN
+                     IF( ABS1( SUM ).GE.BIGNUM*ABS1( D ) ) THEN
+                        TEMP = ONE / ABS1( SUM )
+                        DO 90 JR = JE, J - 1
+                           WORK( JR ) = TEMP*WORK( JR )
+   90                   CONTINUE
+                        XMAX = TEMP*XMAX
+                        SUM = TEMP*SUM
+                     END IF
+                  END IF
+                  WORK( J ) = ZLADIV( -SUM, D )
+                  XMAX = MAX( XMAX, ABS1( WORK( J ) ) )
+  100          CONTINUE
+*
+*              Back transform eigenvector if HOWMNY='B'.
+*
+               IF( ILBACK ) THEN
+                  CALL ZGEMV( 'N', N, N+1-JE, CONE, VL( 1, JE ), LDVL,
+     $                        WORK( JE ), 1, CZERO, WORK( N+1 ), 1 )
+                  ISRC = 2
+                  IBEG = 1
+               ELSE
+                  ISRC = 1
+                  IBEG = JE
+               END IF
+*
+*              Copy and scale eigenvector into column of VL
+*
+               XMAX = ZERO
+               DO 110 JR = IBEG, N
+                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
+  110          CONTINUE
+*
+               IF( XMAX.GT.SAFMIN ) THEN
+                  TEMP = ONE / XMAX
+                  DO 120 JR = IBEG, N
+                     VL( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
+  120             CONTINUE
+               ELSE
+                  IBEG = N + 1
+               END IF
+*
+               DO 130 JR = 1, IBEG - 1
+                  VL( JR, IEIG ) = CZERO
+  130          CONTINUE
+*
+            END IF
+  140    CONTINUE
+      END IF
+*
+*     Right eigenvectors
+*
+      IF( COMPR ) THEN
+         IEIG = IM + 1
+*
+*        Main loop over eigenvalues
+*
+         DO 250 JE = N, 1, -1
+            IF( ILALL ) THEN
+               ILCOMP = .TRUE.
+            ELSE
+               ILCOMP = SELECT( JE )
+            END IF
+            IF( ILCOMP ) THEN
+               IEIG = IEIG - 1
+*
+               IF( ABS1( S( JE, JE ) ).LE.SAFMIN .AND.
+     $             ABS( DBLE( P( JE, JE ) ) ).LE.SAFMIN ) THEN
+*
+*                 Singular matrix pencil -- return unit eigenvector
+*
+                  DO 150 JR = 1, N
+                     VR( JR, IEIG ) = CZERO
+  150             CONTINUE
+                  VR( IEIG, IEIG ) = CONE
+                  GO TO 250
+               END IF
+*
+*              Non-singular eigenvalue:
+*              Compute coefficients  a  and  b  in
+*
+*              ( a A - b B ) x  = 0
+*
+               TEMP = ONE / MAX( ABS1( S( JE, JE ) )*ASCALE,
+     $                ABS( DBLE( P( JE, JE ) ) )*BSCALE, SAFMIN )
+               SALPHA = ( TEMP*S( JE, JE ) )*ASCALE
+               SBETA = ( TEMP*DBLE( P( JE, JE ) ) )*BSCALE
+               ACOEFF = SBETA*ASCALE
+               BCOEFF = SALPHA*BSCALE
+*
+*              Scale to avoid underflow
+*
+               LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEFF ).LT.SMALL
+               LSB = ABS1( SALPHA ).GE.SAFMIN .AND. ABS1( BCOEFF ).LT.
+     $               SMALL
+*
+               SCALE = ONE
+               IF( LSA )
+     $            SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+               IF( LSB )
+     $            SCALE = MAX( SCALE, ( SMALL / ABS1( SALPHA ) )*
+     $                    MIN( BNORM, BIG ) )
+               IF( LSA .OR. LSB ) THEN
+                  SCALE = MIN( SCALE, ONE /
+     $                    ( SAFMIN*MAX( ONE, ABS( ACOEFF ),
+     $                    ABS1( BCOEFF ) ) ) )
+                  IF( LSA ) THEN
+                     ACOEFF = ASCALE*( SCALE*SBETA )
+                  ELSE
+                     ACOEFF = SCALE*ACOEFF
+                  END IF
+                  IF( LSB ) THEN
+                     BCOEFF = BSCALE*( SCALE*SALPHA )
+                  ELSE
+                     BCOEFF = SCALE*BCOEFF
+                  END IF
+               END IF
+*
+               ACOEFA = ABS( ACOEFF )
+               BCOEFA = ABS1( BCOEFF )
+               XMAX = ONE
+               DO 160 JR = 1, N
+                  WORK( JR ) = CZERO
+  160          CONTINUE
+               WORK( JE ) = CONE
+               DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+*              Triangular solve of  (a A - b B) x = 0  (columnwise)
+*
+*              WORK(1:j-1) contains sums w,
+*              WORK(j+1:JE) contains x
+*
+               DO 170 JR = 1, JE - 1
+                  WORK( JR ) = ACOEFF*S( JR, JE ) - BCOEFF*P( JR, JE )
+  170          CONTINUE
+               WORK( JE ) = CONE
+*
+               DO 210 J = JE - 1, 1, -1
+*
+*                 Form x(j) := - w(j) / d
+*                 with scaling and perturbation of the denominator
+*
+                  D = ACOEFF*S( J, J ) - BCOEFF*P( J, J )
+                  IF( ABS1( D ).LE.DMIN )
+     $               D = DCMPLX( DMIN )
+*
+                  IF( ABS1( D ).LT.ONE ) THEN
+                     IF( ABS1( WORK( J ) ).GE.BIGNUM*ABS1( D ) ) THEN
+                        TEMP = ONE / ABS1( WORK( J ) )
+                        DO 180 JR = 1, JE
+                           WORK( JR ) = TEMP*WORK( JR )
+  180                   CONTINUE
+                     END IF
+                  END IF
+*
+                  WORK( J ) = ZLADIV( -WORK( J ), D )
+*
+                  IF( J.GT.1 ) THEN
+*
+*                    w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
+*
+                     IF( ABS1( WORK( J ) ).GT.ONE ) THEN
+                        TEMP = ONE / ABS1( WORK( J ) )
+                        IF( ACOEFA*RWORK( J )+BCOEFA*RWORK( N+J ).GE.
+     $                      BIGNUM*TEMP ) THEN
+                           DO 190 JR = 1, JE
+                              WORK( JR ) = TEMP*WORK( JR )
+  190                      CONTINUE
+                        END IF
+                     END IF
+*
+                     CA = ACOEFF*WORK( J )
+                     CB = BCOEFF*WORK( J )
+                     DO 200 JR = 1, J - 1
+                        WORK( JR ) = WORK( JR ) + CA*S( JR, J ) -
+     $                               CB*P( JR, J )
+  200                CONTINUE
+                  END IF
+  210          CONTINUE
+*
+*              Back transform eigenvector if HOWMNY='B'.
+*
+               IF( ILBACK ) THEN
+                  CALL ZGEMV( 'N', N, JE, CONE, VR, LDVR, WORK, 1,
+     $                        CZERO, WORK( N+1 ), 1 )
+                  ISRC = 2
+                  IEND = N
+               ELSE
+                  ISRC = 1
+                  IEND = JE
+               END IF
+*
+*              Copy and scale eigenvector into column of VR
+*
+               XMAX = ZERO
+               DO 220 JR = 1, IEND
+                  XMAX = MAX( XMAX, ABS1( WORK( ( ISRC-1 )*N+JR ) ) )
+  220          CONTINUE
+*
+               IF( XMAX.GT.SAFMIN ) THEN
+                  TEMP = ONE / XMAX
+                  DO 230 JR = 1, IEND
+                     VR( JR, IEIG ) = TEMP*WORK( ( ISRC-1 )*N+JR )
+  230             CONTINUE
+               ELSE
+                  IEND = 0
+               END IF
+*
+               DO 240 JR = IEND + 1, N
+                  VR( JR, IEIG ) = CZERO
+  240          CONTINUE
+*
+            END IF
+  250    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZTGEVC
+*
+      END
diff --git a/src/lib/lapack/ztgex2.f b/src/lib/lapack/ztgex2.f
new file mode 100644
index 00000000..a0c42aad
--- /dev/null
+++ b/src/lib/lapack/ztgex2.f
@@ -0,0 +1,265 @@
+      SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, J1, INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)
+*  in an upper triangular matrix pair (A, B) by an unitary equivalence
+*  transformation.
+*
+*  (A, B) must be in generalized Schur canonical form, that is, A and
+*  B are both upper triangular.
+*
+*  Optionally, the matrices Q and Z of generalized Schur vectors are
+*  updated.
+*
+*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+*  Arguments
+*  =========
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 arrays, dimensions (LDA,N)
+*          On entry, the matrix A in the pair (A, B).
+*          On exit, the updated matrix A.
+*
+*  LDA     (input)  INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 arrays, dimensions (LDB,N)
+*          On entry, the matrix B in the pair (A, B).
+*          On exit, the updated matrix B.
+*
+*  LDB     (input)  INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
+*          the updated matrix Q.
+*          Not referenced if WANTQ = .FALSE..
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= 1;
+*          If WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,
+*          the updated matrix Z.
+*          Not referenced if WANTZ = .FALSE..
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1;
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  J1      (input) INTEGER
+*          The index to the first block (A11, B11).
+*
+*  INFO    (output) INTEGER
+*           =0:  Successful exit.
+*           =1:  The transformed matrix pair (A, B) would be too far
+*                from generalized Schur form; the problem is ill-
+*                conditioned. 
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  In the current code both weak and strong stability tests are
+*  performed. The user can omit the strong stability test by changing
+*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
+*  details.
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+*      Estimation: Theory, Algorithms and Software, Report UMINF-94.04,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, 1994. Also as LAPACK Working Note 87. To appear in
+*      Numerical Algorithms, 1996.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         CZERO, CONE
+      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
+      DOUBLE PRECISION   TEN
+      PARAMETER          ( TEN = 10.0D+0 )
+      INTEGER            LDST
+      PARAMETER          ( LDST = 2 )
+      LOGICAL            WANDS
+      PARAMETER          ( WANDS = .TRUE. )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            DTRONG, WEAK
+      INTEGER            I, M
+      DOUBLE PRECISION   CQ, CZ, EPS, SA, SB, SCALE, SMLNUM, SS, SUM,
+     $                   THRESH, WS
+      COMPLEX*16         CDUM, F, G, SQ, SZ
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         S( LDST, LDST ), T( LDST, LDST ), WORK( 8 )
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZLACPY, ZLARTG, ZLASSQ, ZROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCONJG, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      INFO = 0
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+*
+      M = LDST
+      WEAK = .FALSE.
+      DTRONG = .FALSE.
+*
+*     Make a local copy of selected block in (A, B)
+*
+      CALL ZLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+      CALL ZLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+*     Compute the threshold for testing the acceptance of swapping.
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' ) / EPS
+      SCALE = DBLE( CZERO )
+      SUM = DBLE( CONE )
+      CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
+      CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
+      CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
+      SA = SCALE*SQRT( SUM )
+      THRESH = MAX( TEN*EPS*SA, SMLNUM )
+*
+*     Compute unitary QL and RQ that swap 1-by-1 and 1-by-1 blocks
+*     using Givens rotations and perform the swap tentatively.
+*
+      F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
+      G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
+      SA = ABS( S( 2, 2 ) )
+      SB = ABS( T( 2, 2 ) )
+      CALL ZLARTG( G, F, CZ, SZ, CDUM )
+      SZ = -SZ
+      CALL ZROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, CZ, DCONJG( SZ ) )
+      CALL ZROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, CZ, DCONJG( SZ ) )
+      IF( SA.GE.SB ) THEN
+         CALL ZLARTG( S( 1, 1 ), S( 2, 1 ), CQ, SQ, CDUM )
+      ELSE
+         CALL ZLARTG( T( 1, 1 ), T( 2, 1 ), CQ, SQ, CDUM )
+      END IF
+      CALL ZROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, CQ, SQ )
+      CALL ZROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, CQ, SQ )
+*
+*     Weak stability test: |S21| + |T21| <= O(EPS F-norm((S, T)))
+*
+      WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
+      WEAK = WS.LE.THRESH
+      IF( .NOT.WEAK )
+     $   GO TO 20
+*
+      IF( WANDS ) THEN
+*
+*        Strong stability test:
+*           F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A, B)))
+*
+         CALL ZLACPY( 'Full', M, M, S, LDST, WORK, M )
+         CALL ZLACPY( 'Full', M, M, T, LDST, WORK( M*M+1 ), M )
+         CALL ZROT( 2, WORK, 1, WORK( 3 ), 1, CZ, -DCONJG( SZ ) )
+         CALL ZROT( 2, WORK( 5 ), 1, WORK( 7 ), 1, CZ, -DCONJG( SZ ) )
+         CALL ZROT( 2, WORK, 2, WORK( 2 ), 2, CQ, -SQ )
+         CALL ZROT( 2, WORK( 5 ), 2, WORK( 6 ), 2, CQ, -SQ )
+         DO 10 I = 1, 2
+            WORK( I ) = WORK( I ) - A( J1+I-1, J1 )
+            WORK( I+2 ) = WORK( I+2 ) - A( J1+I-1, J1+1 )
+            WORK( I+4 ) = WORK( I+4 ) - B( J1+I-1, J1 )
+            WORK( I+6 ) = WORK( I+6 ) - B( J1+I-1, J1+1 )
+   10    CONTINUE
+         SCALE = DBLE( CZERO )
+         SUM = DBLE( CONE )
+         CALL ZLASSQ( 2*M*M, WORK, 1, SCALE, SUM )
+         SS = SCALE*SQRT( SUM )
+         DTRONG = SS.LE.THRESH
+         IF( .NOT.DTRONG )
+     $      GO TO 20
+      END IF
+*
+*     If the swap is accepted ("weakly" and "strongly"), apply the
+*     equivalence transformations to the original matrix pair (A,B)
+*
+      CALL ZROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, CZ,
+     $           DCONJG( SZ ) )
+      CALL ZROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, CZ,
+     $           DCONJG( SZ ) )
+      CALL ZROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA, CQ, SQ )
+      CALL ZROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB, CQ, SQ )
+*
+*     Set  N1 by N2 (2,1) blocks to 0
+*
+      A( J1+1, J1 ) = CZERO
+      B( J1+1, J1 ) = CZERO
+*
+*     Accumulate transformations into Q and Z if requested.
+*
+      IF( WANTZ )
+     $   CALL ZROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, CZ,
+     $              DCONJG( SZ ) )
+      IF( WANTQ )
+     $   CALL ZROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, CQ,
+     $              DCONJG( SQ ) )
+*
+*     Exit with INFO = 0 if swap was successfully performed.
+*
+      RETURN
+*
+*     Exit with INFO = 1 if swap was rejected.
+*
+   20 CONTINUE
+      INFO = 1
+      RETURN
+*
+*     End of ZTGEX2
+*
+      END
diff --git a/src/lib/lapack/ztgexc.f b/src/lib/lapack/ztgexc.f
new file mode 100644
index 00000000..0f57939c
--- /dev/null
+++ b/src/lib/lapack/ztgexc.f
@@ -0,0 +1,206 @@
+      SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                   LDZ, IFST, ILST, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+     $                   Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGEXC reorders the generalized Schur decomposition of a complex
+*  matrix pair (A,B), using an unitary equivalence transformation
+*  (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with
+*  row index IFST is moved to row ILST.
+*
+*  (A, B) must be in generalized Schur canonical form, that is, A and
+*  B are both upper triangular.
+*
+*  Optionally, the matrices Q and Z of generalized Schur vectors are
+*  updated.
+*
+*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*  Arguments
+*  =========
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the upper triangular matrix A in the pair (A, B).
+*          On exit, the updated matrix A.
+*
+*  LDA     (input)  INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)
+*          On entry, the upper triangular matrix B in the pair (A, B).
+*          On exit, the updated matrix B.
+*
+*  LDB     (input)  INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          On entry, if WANTQ = .TRUE., the unitary matrix Q.
+*          On exit, the updated matrix Q.
+*          If WANTQ = .FALSE., Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= 1;
+*          If WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          On entry, if WANTZ = .TRUE., the unitary matrix Z.
+*          On exit, the updated matrix Z.
+*          If WANTZ = .FALSE., Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1;
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  IFST    (input) INTEGER
+*  ILST    (input/output) INTEGER
+*          Specify the reordering of the diagonal blocks of (A, B).
+*          The block with row index IFST is moved to row ILST, by a
+*          sequence of swapping between adjacent blocks.
+*
+*  INFO    (output) INTEGER
+*           =0:  Successful exit.
+*           <0:  if INFO = -i, the i-th argument had an illegal value.
+*           =1:  The transformed matrix pair (A, B) would be too far
+*                from generalized Schur form; the problem is ill-
+*                conditioned. (A, B) may have been partially reordered,
+*                and ILST points to the first row of the current
+*                position of the block being moved.
+*
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+*      Estimation: Theory, Algorithms and Software, Report
+*      UMINF - 94.04, Department of Computing Science, Umea University,
+*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
+*      To appear in Numerical Algorithms, 1996.
+*
+*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+*      for Solving the Generalized Sylvester Equation and Estimating the
+*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, December 1993, Revised April 1994, Also as LAPACK working
+*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
+*      1996.
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER            HERE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTGEX2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input arguments.
+      INFO = 0
+      IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -9
+      ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -11
+      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+         INFO = -12
+      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+         INFO = -13
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGEXC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.1 )
+     $   RETURN
+      IF( IFST.EQ.ILST )
+     $   RETURN
+*
+      IF( IFST.LT.ILST ) THEN
+*
+         HERE = IFST
+*
+   10    CONTINUE
+*
+*        Swap with next one below
+*
+         CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ,
+     $                HERE, INFO )
+         IF( INFO.NE.0 ) THEN
+            ILST = HERE
+            RETURN
+         END IF
+         HERE = HERE + 1
+         IF( HERE.LT.ILST )
+     $      GO TO 10
+         HERE = HERE - 1
+      ELSE
+         HERE = IFST - 1
+*
+   20    CONTINUE
+*
+*        Swap with next one above
+*
+         CALL ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ,
+     $                HERE, INFO )
+         IF( INFO.NE.0 ) THEN
+            ILST = HERE
+            RETURN
+         END IF
+         HERE = HERE - 1
+         IF( HERE.GE.ILST )
+     $      GO TO 20
+         HERE = HERE + 1
+      END IF
+      ILST = HERE
+      RETURN
+*
+*     End of ZTGEXC
+*
+      END
diff --git a/src/lib/lapack/ztgsen.f b/src/lib/lapack/ztgsen.f
new file mode 100644
index 00000000..71ee4cd0
--- /dev/null
+++ b/src/lib/lapack/ztgsen.f
@@ -0,0 +1,652 @@
+      SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
+     $                   ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF,
+     $                   WORK, LWORK, IWORK, LIWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      LOGICAL            WANTQ, WANTZ
+      INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+     $                   M, N
+      DOUBLE PRECISION   PL, PR
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      INTEGER            IWORK( * )
+      DOUBLE PRECISION   DIF( * )
+      COMPLEX*16         A( LDA, * ), ALPHA( * ), B( LDB, * ),
+     $                   BETA( * ), Q( LDQ, * ), WORK( * ), Z( LDZ, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGSEN reorders the generalized Schur decomposition of a complex
+*  matrix pair (A, B) (in terms of an unitary equivalence trans-
+*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
+*  appears in the leading diagonal blocks of the pair (A,B). The leading
+*  columns of Q and Z form unitary bases of the corresponding left and
+*  right eigenspaces (deflating subspaces). (A, B) must be in
+*  generalized Schur canonical form, that is, A and B are both upper
+*  triangular.
+*
+*  ZTGSEN also computes the generalized eigenvalues
+*
+*           w(j)= ALPHA(j) / BETA(j)
+*
+*  of the reordered matrix pair (A, B).
+*
+*  Optionally, the routine computes estimates of reciprocal condition
+*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
+*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
+*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to
+*  the selected cluster and the eigenvalues outside the cluster, resp.,
+*  and norms of "projections" onto left and right eigenspaces w.r.t.
+*  the selected cluster in the (1,1)-block.
+*
+*
+*  Arguments
+*  =========
+*
+*  IJOB    (input) integer
+*          Specifies whether condition numbers are required for the
+*          cluster of eigenvalues (PL and PR) or the deflating subspaces
+*          (Difu and Difl):
+*           =0: Only reorder w.r.t. SELECT. No extras.
+*           =1: Reciprocal of norms of "projections" onto left and right
+*               eigenspaces w.r.t. the selected cluster (PL and PR).
+*           =2: Upper bounds on Difu and Difl. F-norm-based estimate
+*               (DIF(1:2)).
+*           =3: Estimate of Difu and Difl. 1-norm-based estimate
+*               (DIF(1:2)).
+*               About 5 times as expensive as IJOB = 2.
+*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
+*               version to get it all.
+*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
+*
+*  WANTQ   (input) LOGICAL
+*          .TRUE. : update the left transformation matrix Q;
+*          .FALSE.: do not update Q.
+*
+*  WANTZ   (input) LOGICAL
+*          .TRUE. : update the right transformation matrix Z;
+*          .FALSE.: do not update Z.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          SELECT specifies the eigenvalues in the selected cluster. To
+*          select an eigenvalue w(j), SELECT(j) must be set to
+*          .TRUE..
+*
+*  N       (input) INTEGER
+*          The order of the matrices A and B. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension(LDA,N)
+*          On entry, the upper triangular matrix A, in generalized
+*          Schur canonical form.
+*          On exit, A is overwritten by the reordered matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  B       (input/output) COMPLEX*16 array, dimension(LDB,N)
+*          On entry, the upper triangular matrix B, in generalized
+*          Schur canonical form.
+*          On exit, B is overwritten by the reordered matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  ALPHA   (output) COMPLEX*16 array, dimension (N)
+*  BETA    (output) COMPLEX*16 array, dimension (N)
+*          The diagonal elements of A and B, respectively,
+*          when the pair (A,B) has been reduced to generalized Schur
+*          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized
+*          eigenvalues.
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
+*          On exit, Q has been postmultiplied by the left unitary
+*          transformation matrix which reorder (A, B); The leading M
+*          columns of Q form orthonormal bases for the specified pair of
+*          left eigenspaces (deflating subspaces).
+*          If WANTQ = .FALSE., Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q. LDQ >= 1.
+*          If WANTQ = .TRUE., LDQ >= N.
+*
+*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)
+*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
+*          On exit, Z has been postmultiplied by the left unitary
+*          transformation matrix which reorder (A, B); The leading M
+*          columns of Z form orthonormal bases for the specified pair of
+*          left eigenspaces (deflating subspaces).
+*          If WANTZ = .FALSE., Z is not referenced.
+*
+*  LDZ     (input) INTEGER
+*          The leading dimension of the array Z. LDZ >= 1.
+*          If WANTZ = .TRUE., LDZ >= N.
+*
+*  M       (output) INTEGER
+*          The dimension of the specified pair of left and right
+*          eigenspaces, (deflating subspaces) 0 <= M <= N.
+*
+*  PL      (output) DOUBLE PRECISION
+*  PR      (output) DOUBLE PRECISION
+*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
+*          reciprocal  of the norm of "projections" onto left and right
+*          eigenspace with respect to the selected cluster.
+*          0 < PL, PR <= 1.
+*          If M = 0 or M = N, PL = PR  = 1.
+*          If IJOB = 0, 2 or 3 PL, PR are not referenced.
+*
+*  DIF     (output) DOUBLE PRECISION array, dimension (2).
+*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
+*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
+*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
+*          estimates of Difu and Difl, computed using reversed
+*          communication with ZLACN2.
+*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
+*          If IJOB = 0 or 1, DIF is not referenced.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          IF IJOB = 0, WORK is not referenced.  Otherwise,
+*          on exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >=  1
+*          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)
+*          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+*          IF IJOB = 0, IWORK is not referenced.  Otherwise,
+*          on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+*  LIWORK  (input) INTEGER
+*          The dimension of the array IWORK. LIWORK >= 1.
+*          If IJOB = 1, 2 or 4, LIWORK >=  N+2;
+*          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
+*
+*          If LIWORK = -1, then a workspace query is assumed; the
+*          routine only calculates the optimal size of the IWORK array,
+*          returns this value as the first entry of the IWORK array, and
+*          no error message related to LIWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*            =0: Successful exit.
+*            <0: If INFO = -i, the i-th argument had an illegal value.
+*            =1: Reordering of (A, B) failed because the transformed
+*                matrix pair (A, B) would be too far from generalized
+*                Schur form; the problem is very ill-conditioned.
+*                (A, B) may have been partially reordered.
+*                If requested, 0 is returned in DIF(*), PL and PR.
+*
+*
+*  Further Details
+*  ===============
+*
+*  ZTGSEN first collects the selected eigenvalues by computing unitary
+*  U and W that move them to the top left corner of (A, B). In other
+*  words, the selected eigenvalues are the eigenvalues of (A11, B11) in
+*
+*                U'*(A, B)*W = (A11 A12) (B11 B12) n1
+*                              ( 0  A22),( 0  B22) n2
+*                                n1  n2    n1  n2
+*
+*  where N = n1+n2 and U' means the conjugate transpose of U. The first
+*  n1 columns of U and W span the specified pair of left and right
+*  eigenspaces (deflating subspaces) of (A, B).
+*
+*  If (A, B) has been obtained from the generalized real Schur
+*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
+*  reordered generalized Schur form of (C, D) is given by
+*
+*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
+*
+*  and the first n1 columns of Q*U and Z*W span the corresponding
+*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
+*
+*  Note that if the selected eigenvalue is sufficiently ill-conditioned,
+*  then its value may differ significantly from its value before
+*  reordering.
+*
+*  The reciprocal condition numbers of the left and right eigenspaces
+*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
+*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
+*
+*  The Difu and Difl are defined as:
+*
+*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
+*  and
+*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
+*
+*  where sigma-min(Zu) is the smallest singular value of the
+*  (2*n1*n2)-by-(2*n1*n2) matrix
+*
+*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]
+*            [ kron(In2, B11)  -kron(B22', In1) ].
+*
+*  Here, Inx is the identity matrix of size nx and A22' is the
+*  transpose of A22. kron(X, Y) is the Kronecker product between
+*  the matrices X and Y.
+*
+*  When DIF(2) is small, small changes in (A, B) can cause large changes
+*  in the deflating subspace. An approximate (asymptotic) bound on the
+*  maximum angular error in the computed deflating subspaces is
+*
+*       EPS * norm((A, B)) / DIF(2),
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal norm of the projectors on the left and right
+*  eigenspaces associated with (A11, B11) may be returned in PL and PR.
+*  They are computed as follows. First we compute L and R so that
+*  P*(A, B)*Q is block diagonal, where
+*
+*       P = ( I -L ) n1           Q = ( I R ) n1
+*           ( 0  I ) n2    and        ( 0 I ) n2
+*             n1 n2                    n1 n2
+*
+*  and (L, R) is the solution to the generalized Sylvester equation
+*
+*       A11*R - L*A22 = -A12
+*       B11*R - L*B22 = -B12
+*
+*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
+*  An approximate (asymptotic) bound on the average absolute error of
+*  the selected eigenvalues is
+*
+*       EPS * norm((A, B)) / PL.
+*
+*  There are also global error bounds which valid for perturbations up
+*  to a certain restriction:  A lower bound (x) on the smallest
+*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
+*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
+*  (i.e. (A + E, B + F), is
+*
+*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
+*
+*  An approximate bound on x can be computed from DIF(1:2), PL and PR.
+*
+*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
+*  (L', R') and unperturbed (L, R) left and right deflating subspaces
+*  associated with the selected cluster in the (1,1)-blocks can be
+*  bounded as
+*
+*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
+*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
+*
+*  See LAPACK User's Guide section 4.11 or the following references
+*  for more information.
+*
+*  Note that if the default method for computing the Frobenius-norm-
+*  based estimate DIF is not wanted (see ZLATDF), then the parameter
+*  IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
+*  (IJOB = 2 will be used)). See ZTGSYL for more details.
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  References
+*  ==========
+*
+*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+*      Estimation: Theory, Algorithms and Software, Report
+*      UMINF - 94.04, Department of Computing Science, Umea University,
+*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
+*      To appear in Numerical Algorithms, 1996.
+*
+*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+*      for Solving the Generalized Sylvester Equation and Estimating the
+*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, December 1993, Revised April 1994, Also as LAPACK working
+*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
+*      1996.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            IDIFJB
+      PARAMETER          ( IDIFJB = 3 )
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, SWAP, WANTD, WANTD1, WANTD2, WANTP
+      INTEGER            I, IERR, IJB, K, KASE, KS, LIWMIN, LWMIN, MN2,
+     $                   N1, N2
+      DOUBLE PRECISION   DSCALE, DSUM, RDSCAL, SAFMIN
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZLASSQ, ZSCAL, ZTGEXC,
+     $                   ZTGSYL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DCMPLX, DCONJG, MAX, SQRT
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH
+      EXTERNAL           DLAMCH
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+      IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -13
+      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+         INFO = -15
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSEN', -INFO )
+         RETURN
+      END IF
+*
+      IERR = 0
+*
+      WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
+      WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
+      WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
+      WANTD = WANTD1 .OR. WANTD2
+*
+*     Set M to the dimension of the specified pair of deflating
+*     subspaces.
+*
+      M = 0
+      DO 10 K = 1, N
+         ALPHA( K ) = A( K, K )
+         BETA( K ) = B( K, K )
+         IF( K.LT.N ) THEN
+            IF( SELECT( K ) )
+     $         M = M + 1
+         ELSE
+            IF( SELECT( N ) )
+     $         M = M + 1
+         END IF
+   10 CONTINUE
+*
+      IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+         LWMIN = MAX( 1, 2*M*( N-M ) )
+         LIWMIN = MAX( 1, N+2 )
+      ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
+         LWMIN = MAX( 1, 4*M*( N-M ) )
+         LIWMIN = MAX( 1, 2*M*( N-M ), N+2 )
+      ELSE
+         LWMIN = 1
+         LIWMIN = 1
+      END IF
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -21
+      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -23
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSEN', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( M.EQ.N .OR. M.EQ.0 ) THEN
+         IF( WANTP ) THEN
+            PL = ONE
+            PR = ONE
+         END IF
+         IF( WANTD ) THEN
+            DSCALE = ZERO
+            DSUM = ONE
+            DO 20 I = 1, N
+               CALL ZLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+               CALL ZLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
+   20       CONTINUE
+            DIF( 1 ) = DSCALE*SQRT( DSUM )
+            DIF( 2 ) = DIF( 1 )
+         END IF
+         GO TO 70
+      END IF
+*
+*     Get machine constant
+*
+      SAFMIN = DLAMCH( 'S' )
+*
+*     Collect the selected blocks at the top-left corner of (A, B).
+*
+      KS = 0
+      DO 30 K = 1, N
+         SWAP = SELECT( K )
+         IF( SWAP ) THEN
+            KS = KS + 1
+*
+*           Swap the K-th block to position KS. Compute unitary Q
+*           and Z that will swap adjacent diagonal blocks in (A, B).
+*
+            IF( K.NE.KS )
+     $         CALL ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+     $                      LDZ, K, KS, IERR )
+*
+            IF( IERR.GT.0 ) THEN
+*
+*              Swap is rejected: exit.
+*
+               INFO = 1
+               IF( WANTP ) THEN
+                  PL = ZERO
+                  PR = ZERO
+               END IF
+               IF( WANTD ) THEN
+                  DIF( 1 ) = ZERO
+                  DIF( 2 ) = ZERO
+               END IF
+               GO TO 70
+            END IF
+         END IF
+   30 CONTINUE
+      IF( WANTP ) THEN
+*
+*        Solve generalized Sylvester equation for R and L:
+*                   A11 * R - L * A22 = A12
+*                   B11 * R - L * B22 = B12
+*
+         N1 = M
+         N2 = N - M
+         I = N1 + 1
+         CALL ZLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+         CALL ZLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+     $                N1 )
+         IJB = 0
+         CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+     $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
+     $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
+     $                LWORK-2*N1*N2, IWORK, IERR )
+*
+*        Estimate the reciprocal of norms of "projections" onto
+*        left and right eigenspaces
+*
+         RDSCAL = ZERO
+         DSUM = ONE
+         CALL ZLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
+         PL = RDSCAL*SQRT( DSUM )
+         IF( PL.EQ.ZERO ) THEN
+            PL = ONE
+         ELSE
+            PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
+         END IF
+         RDSCAL = ZERO
+         DSUM = ONE
+         CALL ZLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
+         PR = RDSCAL*SQRT( DSUM )
+         IF( PR.EQ.ZERO ) THEN
+            PR = ONE
+         ELSE
+            PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
+         END IF
+      END IF
+      IF( WANTD ) THEN
+*
+*        Compute estimates Difu and Difl.
+*
+         IF( WANTD1 ) THEN
+            N1 = M
+            N2 = N - M
+            I = N1 + 1
+            IJB = IDIFJB
+*
+*           Frobenius norm-based Difu estimate.
+*
+            CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+     $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
+     $                   N1, DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
+     $                   LWORK-2*N1*N2, IWORK, IERR )
+*
+*           Frobenius norm-based Difl estimate.
+*
+            CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
+     $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
+     $                   N2, DSCALE, DIF( 2 ), WORK( N1*N2*2+1 ),
+     $                   LWORK-2*N1*N2, IWORK, IERR )
+         ELSE
+*
+*           Compute 1-norm-based estimates of Difu and Difl using
+*           reversed communication with ZLACN2. In each step a
+*           generalized Sylvester equation or a transposed variant
+*           is solved.
+*
+            KASE = 0
+            N1 = M
+            N2 = N - M
+            I = N1 + 1
+            IJB = 0
+            MN2 = 2*N1*N2
+*
+*           1-norm-based estimate of Difu.
+*
+   40       CONTINUE
+            CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 1 ), KASE,
+     $                   ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation
+*
+                  CALL ZTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+     $                         WORK, N1, B, LDB, B( I, I ), LDB,
+     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               ELSE
+*
+*                 Solve the transposed variant.
+*
+                  CALL ZTGSYL( 'C', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+     $                         WORK, N1, B, LDB, B( I, I ), LDB,
+     $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               END IF
+               GO TO 40
+            END IF
+            DIF( 1 ) = DSCALE / DIF( 1 )
+*
+*           1-norm-based estimate of Difl.
+*
+   50       CONTINUE
+            CALL ZLACN2( MN2, WORK( MN2+1 ), WORK, DIF( 2 ), KASE,
+     $                   ISAVE )
+            IF( KASE.NE.0 ) THEN
+               IF( KASE.EQ.1 ) THEN
+*
+*                 Solve generalized Sylvester equation
+*
+                  CALL ZTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+     $                         WORK, N2, B( I, I ), LDB, B, LDB,
+     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               ELSE
+*
+*                 Solve the transposed variant.
+*
+                  CALL ZTGSYL( 'C', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+     $                         WORK, N2, B, LDB, B( I, I ), LDB,
+     $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+     $                         WORK( N1*N2*2+1 ), LWORK-2*N1*N2, IWORK,
+     $                         IERR )
+               END IF
+               GO TO 50
+            END IF
+            DIF( 2 ) = DSCALE / DIF( 2 )
+         END IF
+      END IF
+*
+*     If B(K,K) is complex, make it real and positive (normalization
+*     of the generalized Schur form) and Store the generalized
+*     eigenvalues of reordered pair (A, B)
+*
+      DO 60 K = 1, N
+         DSCALE = ABS( B( K, K ) )
+         IF( DSCALE.GT.SAFMIN ) THEN
+            WORK( 1 ) = DCONJG( B( K, K ) / DSCALE )
+            WORK( 2 ) = B( K, K ) / DSCALE
+            B( K, K ) = DSCALE
+            CALL ZSCAL( N-K, WORK( 1 ), B( K, K+1 ), LDB )
+            CALL ZSCAL( N-K+1, WORK( 1 ), A( K, K ), LDA )
+            IF( WANTQ )
+     $         CALL ZSCAL( N, WORK( 2 ), Q( 1, K ), 1 )
+         ELSE
+            B( K, K ) = DCMPLX( ZERO, ZERO )
+         END IF
+*
+         ALPHA( K ) = A( K, K )
+         BETA( K ) = B( K, K )
+*
+   60 CONTINUE
+*
+   70 CONTINUE
+*
+      WORK( 1 ) = LWMIN
+      IWORK( 1 ) = LIWMIN
+*
+      RETURN
+*
+*     End of ZTGSEN
+*
+      END
diff --git a/src/lib/lapack/ztgsy2.f b/src/lib/lapack/ztgsy2.f
new file mode 100644
index 00000000..82ec5eb1
--- /dev/null
+++ b/src/lib/lapack/ztgsy2.f
@@ -0,0 +1,361 @@
+      SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
+     $                   INFO )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N
+      DOUBLE PRECISION   RDSCAL, RDSUM, SCALE
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGSY2 solves the generalized Sylvester equation
+*
+*              A * R - L * B = scale *   C               (1)
+*              D * R - L * E = scale * F
+*
+*  using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
+*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
+*  N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
+*  (i.e., (A,D) and (B,E) in generalized Schur form).
+*
+*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
+*  scaling factor chosen to avoid overflow.
+*
+*  In matrix notation solving equation (1) corresponds to solve
+*  Zx = scale * b, where Z is defined as
+*
+*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)
+*             [ kron(In, D)  -kron(E', Im) ],
+*
+*  Ik is the identity matrix of size k and X' is the transpose of X.
+*  kron(X, Y) is the Kronecker product between the matrices X and Y.
+*
+*  If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b
+*  is solved for, which is equivalent to solve for R and L in
+*
+*              A' * R  + D' * L   = scale *  C           (3)
+*              R  * B' + L  * E'  = scale * -F
+*
+*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =
+*  = sigma_min(Z) using reverse communicaton with ZLACON.
+*
+*  ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL
+*  of an upper bound on the separation between to matrix pairs. Then
+*  the input (A, D), (B, E) are sub-pencils of two matrix pairs in
+*  ZTGSYL.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N', solve the generalized Sylvester equation (1).
+*          = 'T': solve the 'transposed' system (3).
+*
+*  IJOB    (input) INTEGER
+*          Specifies what kind of functionality to be performed.
+*          =0: solve (1) only.
+*          =1: A contribution from this subsystem to a Frobenius
+*              norm-based estimate of the separation between two matrix
+*              pairs is computed. (look ahead strategy is used).
+*          =2: A contribution from this subsystem to a Frobenius
+*              norm-based estimate of the separation between two matrix
+*              pairs is computed. (DGECON on sub-systems is used.)
+*          Not referenced if TRANS = 'T'.
+*
+*  M       (input) INTEGER
+*          On entry, M specifies the order of A and D, and the row
+*          dimension of C, F, R and L.
+*
+*  N       (input) INTEGER
+*          On entry, N specifies the order of B and E, and the column
+*          dimension of C, F, R and L.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA, M)
+*          On entry, A contains an upper triangular matrix.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the matrix A. LDA >= max(1, M).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB, N)
+*          On entry, B contains an upper triangular matrix.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the matrix B. LDB >= max(1, N).
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC, N)
+*          On entry, C contains the right-hand-side of the first matrix
+*          equation in (1).
+*          On exit, if IJOB = 0, C has been overwritten by the solution
+*          R.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the matrix C. LDC >= max(1, M).
+*
+*  D       (input) COMPLEX*16 array, dimension (LDD, M)
+*          On entry, D contains an upper triangular matrix.
+*
+*  LDD     (input) INTEGER
+*          The leading dimension of the matrix D. LDD >= max(1, M).
+*
+*  E       (input) COMPLEX*16 array, dimension (LDE, N)
+*          On entry, E contains an upper triangular matrix.
+*
+*  LDE     (input) INTEGER
+*          The leading dimension of the matrix E. LDE >= max(1, N).
+*
+*  F       (input/output) COMPLEX*16 array, dimension (LDF, N)
+*          On entry, F contains the right-hand-side of the second matrix
+*          equation in (1).
+*          On exit, if IJOB = 0, F has been overwritten by the solution
+*          L.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the matrix F. LDF >= max(1, M).
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
+*          R and L (C and F on entry) will hold the solutions to a
+*          slightly perturbed system but the input matrices A, B, D and
+*          E have not been changed. If SCALE = 0, R and L will hold the
+*          solutions to the homogeneous system with C = F = 0.
+*          Normally, SCALE = 1.
+*
+*  RDSUM   (input/output) DOUBLE PRECISION
+*          On entry, the sum of squares of computed contributions to
+*          the Dif-estimate under computation by ZTGSYL, where the
+*          scaling factor RDSCAL (see below) has been factored out.
+*          On exit, the corresponding sum of squares updated with the
+*          contributions from the current sub-system.
+*          If TRANS = 'T' RDSUM is not touched.
+*          NOTE: RDSUM only makes sense when ZTGSY2 is called by
+*          ZTGSYL.
+*
+*  RDSCAL  (input/output) DOUBLE PRECISION
+*          On entry, scaling factor used to prevent overflow in RDSUM.
+*          On exit, RDSCAL is updated w.r.t. the current contributions
+*          in RDSUM.
+*          If TRANS = 'T', RDSCAL is not touched.
+*          NOTE: RDSCAL only makes sense when ZTGSY2 is called by
+*          ZTGSYL.
+*
+*  INFO    (output) INTEGER
+*          On exit, if INFO is set to
+*            =0: Successful exit
+*            <0: If INFO = -i, input argument number i is illegal.
+*            >0: The matrix pairs (A, D) and (B, E) have common or very
+*                close eigenvalues.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      INTEGER            LDZ
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, LDZ = 2 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRAN
+      INTEGER            I, IERR, J, K
+      DOUBLE PRECISION   SCALOC
+      COMPLEX*16         ALPHA
+*     ..
+*     .. Local Arrays ..
+      INTEGER            IPIV( LDZ ), JPIV( LDZ )
+      COMPLEX*16         RHS( LDZ ), Z( LDZ, LDZ )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZAXPY, ZGESC2, ZGETC2, ZLATDF, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCMPLX, DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input parameters
+*
+      INFO = 0
+      IERR = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( NOTRAN ) THEN
+         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
+            INFO = -2
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( M.LE.0 ) THEN
+            INFO = -3
+         ELSE IF( N.LE.0 ) THEN
+            INFO = -4
+         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+            INFO = -5
+         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+            INFO = -8
+         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+            INFO = -10
+         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+            INFO = -12
+         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+            INFO = -14
+         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSY2', -INFO )
+         RETURN
+      END IF
+*
+      IF( NOTRAN ) THEN
+*
+*        Solve (I, J) - system
+*           A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+*           D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+*        for I = M, M - 1, ..., 1; J = 1, 2, ..., N
+*
+         SCALE = ONE
+         SCALOC = ONE
+         DO 30 J = 1, N
+            DO 20 I = M, 1, -1
+*
+*              Build 2 by 2 system
+*
+               Z( 1, 1 ) = A( I, I )
+               Z( 2, 1 ) = D( I, I )
+               Z( 1, 2 ) = -B( J, J )
+               Z( 2, 2 ) = -E( J, J )
+*
+*              Set up right hand side(s)
+*
+               RHS( 1 ) = C( I, J )
+               RHS( 2 ) = F( I, J )
+*
+*              Solve Z * x = RHS
+*
+               CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
+               IF( IERR.GT.0 )
+     $            INFO = IERR
+               IF( IJOB.EQ.0 ) THEN
+                  CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 10 K = 1, N
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              C( 1, K ), 1 )
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              F( 1, K ), 1 )
+   10                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+               ELSE
+                  CALL ZLATDF( IJOB, LDZ, Z, LDZ, RHS, RDSUM, RDSCAL,
+     $                         IPIV, JPIV )
+               END IF
+*
+*              Unpack solution vector(s)
+*
+               C( I, J ) = RHS( 1 )
+               F( I, J ) = RHS( 2 )
+*
+*              Substitute R(I, J) and L(I, J) into remaining equation.
+*
+               IF( I.GT.1 ) THEN
+                  ALPHA = -RHS( 1 )
+                  CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, C( 1, J ), 1 )
+                  CALL ZAXPY( I-1, ALPHA, D( 1, I ), 1, F( 1, J ), 1 )
+               END IF
+               IF( J.LT.N ) THEN
+                  CALL ZAXPY( N-J, RHS( 2 ), B( J, J+1 ), LDB,
+     $                        C( I, J+1 ), LDC )
+                  CALL ZAXPY( N-J, RHS( 2 ), E( J, J+1 ), LDE,
+     $                        F( I, J+1 ), LDF )
+               END IF
+*
+   20       CONTINUE
+   30    CONTINUE
+      ELSE
+*
+*        Solve transposed (I, J) - system:
+*           A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
+*           R(I, I) * B(J, J) + L(I, J) * E(J, J)   = -F(I, J)
+*        for I = 1, 2, ..., M, J = N, N - 1, ..., 1
+*
+         SCALE = ONE
+         SCALOC = ONE
+         DO 80 I = 1, M
+            DO 70 J = N, 1, -1
+*
+*              Build 2 by 2 system Z'
+*
+               Z( 1, 1 ) = DCONJG( A( I, I ) )
+               Z( 2, 1 ) = -DCONJG( B( J, J ) )
+               Z( 1, 2 ) = DCONJG( D( I, I ) )
+               Z( 2, 2 ) = -DCONJG( E( J, J ) )
+*
+*
+*              Set up right hand side(s)
+*
+               RHS( 1 ) = C( I, J )
+               RHS( 2 ) = F( I, J )
+*
+*              Solve Z' * x = RHS
+*
+               CALL ZGETC2( LDZ, Z, LDZ, IPIV, JPIV, IERR )
+               IF( IERR.GT.0 )
+     $            INFO = IERR
+               CALL ZGESC2( LDZ, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 40 K = 1, N
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                           1 )
+   40             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+*
+*              Unpack solution vector(s)
+*
+               C( I, J ) = RHS( 1 )
+               F( I, J ) = RHS( 2 )
+*
+*              Substitute R(I, J) and L(I, J) into remaining equation.
+*
+               DO 50 K = 1, J - 1
+                  F( I, K ) = F( I, K ) + RHS( 1 )*DCONJG( B( K, J ) ) +
+     $                        RHS( 2 )*DCONJG( E( K, J ) )
+   50          CONTINUE
+               DO 60 K = I + 1, M
+                  C( K, J ) = C( K, J ) - DCONJG( A( I, K ) )*RHS( 1 ) -
+     $                        DCONJG( D( I, K ) )*RHS( 2 )
+   60          CONTINUE
+*
+   70       CONTINUE
+   80    CONTINUE
+      END IF
+      RETURN
+*
+*     End of ZTGSY2
+*
+      END
diff --git a/src/lib/lapack/ztgsyl.f b/src/lib/lapack/ztgsyl.f
new file mode 100644
index 00000000..af808a31
--- /dev/null
+++ b/src/lib/lapack/ztgsyl.f
@@ -0,0 +1,575 @@
+      SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
+     $                   IWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANS
+      INTEGER            IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
+     $                   LWORK, M, N
+      DOUBLE PRECISION   DIF, SCALE
+*     ..
+*     .. Array Arguments ..
+      INTEGER            IWORK( * )
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * ),
+     $                   D( LDD, * ), E( LDE, * ), F( LDF, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTGSYL solves the generalized Sylvester equation:
+*
+*              A * R - L * B = scale * C            (1)
+*              D * R - L * E = scale * F
+*
+*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and
+*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
+*  respectively, with complex entries. A, B, D and E are upper
+*  triangular (i.e., (A,D) and (B,E) in generalized Schur form).
+*
+*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
+*  is an output scaling factor chosen to avoid overflow.
+*
+*  In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
+*  is defined as
+*
+*         Z = [ kron(In, A)  -kron(B', Im) ]        (2)
+*             [ kron(In, D)  -kron(E', Im) ],
+*
+*  Here Ix is the identity matrix of size x and X' is the conjugate
+*  transpose of X. Kron(X, Y) is the Kronecker product between the
+*  matrices X and Y.
+*
+*  If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
+*  is solved for, which is equivalent to solve for R and L in
+*
+*              A' * R + D' * L = scale * C           (3)
+*              R * B' + L * E' = scale * -F
+*
+*  This case (TRANS = 'C') is used to compute an one-norm-based estimate
+*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
+*  and (B,E), using ZLACON.
+*
+*  If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of
+*  Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
+*  reciprocal of the smallest singular value of Z.
+*
+*  This is a level-3 BLAS algorithm.
+*
+*  Arguments
+*  =========
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': solve the generalized sylvester equation (1).
+*          = 'C': solve the "conjugate transposed" system (3).
+*
+*  IJOB    (input) INTEGER
+*          Specifies what kind of functionality to be performed.
+*          =0: solve (1) only.
+*          =1: The functionality of 0 and 3.
+*          =2: The functionality of 0 and 4.
+*          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
+*              (look ahead strategy is used).
+*          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
+*              (ZGECON on sub-systems is used).
+*          Not referenced if TRANS = 'C'.
+*
+*  M       (input) INTEGER
+*          The order of the matrices A and D, and the row dimension of
+*          the matrices C, F, R and L.
+*
+*  N       (input) INTEGER
+*          The order of the matrices B and E, and the column dimension
+*          of the matrices C, F, R and L.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA, M)
+*          The upper triangular matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1, M).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB, N)
+*          The upper triangular matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1, N).
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC, N)
+*          On entry, C contains the right-hand-side of the first matrix
+*          equation in (1) or (3).
+*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by
+*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
+*          the solution achieved during the computation of the
+*          Dif-estimate.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1, M).
+*
+*  D       (input) COMPLEX*16 array, dimension (LDD, M)
+*          The upper triangular matrix D.
+*
+*  LDD     (input) INTEGER
+*          The leading dimension of the array D. LDD >= max(1, M).
+*
+*  E       (input) COMPLEX*16 array, dimension (LDE, N)
+*          The upper triangular matrix E.
+*
+*  LDE     (input) INTEGER
+*          The leading dimension of the array E. LDE >= max(1, N).
+*
+*  F       (input/output) COMPLEX*16 array, dimension (LDF, N)
+*          On entry, F contains the right-hand-side of the second matrix
+*          equation in (1) or (3).
+*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by
+*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
+*          the solution achieved during the computation of the
+*          Dif-estimate.
+*
+*  LDF     (input) INTEGER
+*          The leading dimension of the array F. LDF >= max(1, M).
+*
+*  DIF     (output) DOUBLE PRECISION
+*          On exit DIF is the reciprocal of a lower bound of the
+*          reciprocal of the Dif-function, i.e. DIF is an upper bound of
+*          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
+*          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          On exit SCALE is the scaling factor in (1) or (3).
+*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
+*          to a slightly perturbed system but the input matrices A, B,
+*          D and E have not been changed. If SCALE = 0, R and L will
+*          hold the solutions to the homogenious system with C = F = 0.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK > = 1.
+*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  IWORK   (workspace) INTEGER array, dimension (M+N+2)
+*          If IJOB = 0, IWORK is not referenced.
+*
+*  INFO    (output) INTEGER
+*            =0: successful exit
+*            <0: If INFO = -i, the i-th argument had an illegal value.
+*            >0: (A, D) and (B, E) have common or very close
+*                eigenvalues.
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+*     Umea University, S-901 87 Umea, Sweden.
+*
+*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+*      for Solving the Generalized Sylvester Equation and Estimating the
+*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+*      Department of Computing Science, Umea University, S-901 87 Umea,
+*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
+*      No 1, 1996.
+*
+*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
+*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
+*      Appl., 15(4):1045-1060, 1994.
+*
+*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
+*      Condition Estimators for Solving the Generalized Sylvester
+*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
+*      July 1989, pp 745-751.
+*
+*  =====================================================================
+*  Replaced various illegal calls to CCOPY by calls to CLASET.
+*  Sven Hammarling, 1/5/02.
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CZERO
+      PARAMETER          ( CZERO = (0.0D+0, 0.0D+0) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, NOTRAN
+      INTEGER            I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
+     $                   LINFO, LWMIN, MB, NB, P, PQ, Q
+      DOUBLE PRECISION   DSCALE, DSUM, SCALE2, SCALOC
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZGEMM, ZLACPY, ZLASET, ZSCAL, ZTGSY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DBLE, DCMPLX, MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test input parameters
+*
+      INFO = 0
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( NOTRAN ) THEN
+         IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
+            INFO = -2
+         END IF
+      END IF
+      IF( INFO.EQ.0 ) THEN
+         IF( M.LE.0 ) THEN
+            INFO = -3
+         ELSE IF( N.LE.0 ) THEN
+            INFO = -4
+         ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+            INFO = -6
+         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+            INFO = -8
+         ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+            INFO = -10
+         ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+            INFO = -12
+         ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+            INFO = -14
+         ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+            INFO = -16
+         END IF
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( NOTRAN ) THEN
+            IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
+               LWMIN = MAX( 1, 2*M*N )
+            ELSE
+               LWMIN = 1
+            END IF
+         ELSE
+            LWMIN = 1
+         END IF
+         WORK( 1 ) = LWMIN
+*
+         IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+            INFO = -20
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTGSYL', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         SCALE = 1
+         IF( NOTRAN ) THEN
+            IF( IJOB.NE.0 ) THEN
+               DIF = 0
+            END IF
+         END IF
+         RETURN
+      END IF
+*
+*     Determine  optimal block sizes MB and NB
+*
+      MB = ILAENV( 2, 'ZTGSYL', TRANS, M, N, -1, -1 )
+      NB = ILAENV( 5, 'ZTGSYL', TRANS, M, N, -1, -1 )
+*
+      ISOLVE = 1
+      IFUNC = 0
+      IF( NOTRAN ) THEN
+         IF( IJOB.GE.3 ) THEN
+            IFUNC = IJOB - 2
+            CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+            CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
+         ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
+            ISOLVE = 2
+         END IF
+      END IF
+*
+      IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
+     $     THEN
+*
+*        Use unblocked Level 2 solver
+*
+         DO 30 IROUND = 1, ISOLVE
+*
+            SCALE = ONE
+            DSCALE = ZERO
+            DSUM = ONE
+            PQ = M*N
+            CALL ZTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
+     $                   LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
+     $                   INFO )
+            IF( DSCALE.NE.ZERO ) THEN
+               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+               END IF
+            END IF
+            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+               IF( NOTRAN ) THEN
+                  IFUNC = IJOB
+               END IF
+               SCALE2 = SCALE
+               CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+               SCALE = SCALE2
+            END IF
+   30    CONTINUE
+*
+         RETURN
+*
+      END IF
+*
+*     Determine block structure of A
+*
+      P = 0
+      I = 1
+   40 CONTINUE
+      IF( I.GT.M )
+     $   GO TO 50
+      P = P + 1
+      IWORK( P ) = I
+      I = I + MB
+      IF( I.GE.M )
+     $   GO TO 50
+      GO TO 40
+   50 CONTINUE
+      IWORK( P+1 ) = M + 1
+      IF( IWORK( P ).EQ.IWORK( P+1 ) )
+     $   P = P - 1
+*
+*     Determine block structure of B
+*
+      Q = P + 1
+      J = 1
+   60 CONTINUE
+      IF( J.GT.N )
+     $   GO TO 70
+*
+      Q = Q + 1
+      IWORK( Q ) = J
+      J = J + NB
+      IF( J.GE.N )
+     $   GO TO 70
+      GO TO 60
+*
+   70 CONTINUE
+      IWORK( Q+1 ) = N + 1
+      IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
+     $   Q = Q - 1
+*
+      IF( NOTRAN ) THEN
+         DO 150 IROUND = 1, ISOLVE
+*
+*           Solve (I, J) - subsystem
+*               A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+*               D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+*           for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
+*
+            PQ = 0
+            SCALE = ONE
+            DSCALE = ZERO
+            DSUM = ONE
+            DO 130 J = P + 2, Q
+               JS = IWORK( J )
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               DO 120 I = P, 1, -1
+                  IS = IWORK( I )
+                  IE = IWORK( I+1 ) - 1
+                  MB = IE - IS + 1
+                  CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+     $                         B( JS, JS ), LDB, C( IS, JS ), LDC,
+     $                         D( IS, IS ), LDD, E( JS, JS ), LDE,
+     $                         F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+     $                         LINFO )
+                  IF( LINFO.GT.0 )
+     $               INFO = LINFO
+                  PQ = PQ + MB*NB
+                  IF( SCALOC.NE.ONE ) THEN
+                     DO 80 K = 1, JS - 1
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              C( 1, K ), 1 )
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              F( 1, K ), 1 )
+   80                CONTINUE
+                     DO 90 K = JS, JE
+                        CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
+     $                              C( 1, K ), 1 )
+                        CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
+     $                              F( 1, K ), 1 )
+   90                CONTINUE
+                     DO 100 K = JS, JE
+                        CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
+     $                              C( IE+1, K ), 1 )
+                        CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
+     $                              F( IE+1, K ), 1 )
+  100                CONTINUE
+                     DO 110 K = JE + 1, N
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              C( 1, K ), 1 )
+                        CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ),
+     $                              F( 1, K ), 1 )
+  110                CONTINUE
+                     SCALE = SCALE*SCALOC
+                  END IF
+*
+*                 Substitute R(I,J) and L(I,J) into remaining equation.
+*
+                  IF( I.GT.1 ) THEN
+                     CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
+     $                           DCMPLX( -ONE, ZERO ), A( 1, IS ), LDA,
+     $                           C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
+     $                           C( 1, JS ), LDC )
+                     CALL ZGEMM( 'N', 'N', IS-1, NB, MB,
+     $                           DCMPLX( -ONE, ZERO ), D( 1, IS ), LDD,
+     $                           C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
+     $                           F( 1, JS ), LDF )
+                  END IF
+                  IF( J.LT.Q ) THEN
+                     CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
+     $                           DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                           B( JS, JE+1 ), LDB,
+     $                           DCMPLX( ONE, ZERO ), C( IS, JE+1 ),
+     $                           LDC )
+                     CALL ZGEMM( 'N', 'N', MB, N-JE, NB,
+     $                           DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                           E( JS, JE+1 ), LDE,
+     $                           DCMPLX( ONE, ZERO ), F( IS, JE+1 ),
+     $                           LDF )
+                  END IF
+  120          CONTINUE
+  130       CONTINUE
+            IF( DSCALE.NE.ZERO ) THEN
+               IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+                  DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+               ELSE
+                  DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+               END IF
+            END IF
+            IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+               IF( NOTRAN ) THEN
+                  IFUNC = IJOB
+               END IF
+               SCALE2 = SCALE
+               CALL ZLACPY( 'F', M, N, C, LDC, WORK, M )
+               CALL ZLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, C, LDC )
+               CALL ZLASET( 'F', M, N, CZERO, CZERO, F, LDF )
+            ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+               CALL ZLACPY( 'F', M, N, WORK, M, C, LDC )
+               CALL ZLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+               SCALE = SCALE2
+            END IF
+  150    CONTINUE
+      ELSE
+*
+*        Solve transposed (I, J)-subsystem
+*            A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
+*            R(I, J) * B(J, J)  + L(I, J) * E(J, J) = -F(I, J)
+*        for I = 1,2,..., P; J = Q, Q-1,..., 1
+*
+         SCALE = ONE
+         DO 210 I = 1, P
+            IS = IWORK( I )
+            IE = IWORK( I+1 ) - 1
+            MB = IE - IS + 1
+            DO 200 J = Q, P + 2, -1
+               JS = IWORK( J )
+               JE = IWORK( J+1 ) - 1
+               NB = JE - JS + 1
+               CALL ZTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+     $                      B( JS, JS ), LDB, C( IS, JS ), LDC,
+     $                      D( IS, IS ), LDD, E( JS, JS ), LDE,
+     $                      F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+     $                      LINFO )
+               IF( LINFO.GT.0 )
+     $            INFO = LINFO
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 160 K = 1, JS - 1
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                           1 )
+  160             CONTINUE
+                  DO 170 K = JS, JE
+                     CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
+     $                           C( 1, K ), 1 )
+                     CALL ZSCAL( IS-1, DCMPLX( SCALOC, ZERO ),
+     $                           F( 1, K ), 1 )
+  170             CONTINUE
+                  DO 180 K = JS, JE
+                     CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
+     $                           C( IE+1, K ), 1 )
+                     CALL ZSCAL( M-IE, DCMPLX( SCALOC, ZERO ),
+     $                           F( IE+1, K ), 1 )
+  180             CONTINUE
+                  DO 190 K = JE + 1, N
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), C( 1, K ),
+     $                           1 )
+                     CALL ZSCAL( M, DCMPLX( SCALOC, ZERO ), F( 1, K ),
+     $                           1 )
+  190             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+*
+*              Substitute R(I,J) and L(I,J) into remaining equation.
+*
+               IF( J.GT.P+2 ) THEN
+                  CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
+     $                        DCMPLX( ONE, ZERO ), C( IS, JS ), LDC,
+     $                        B( 1, JS ), LDB, DCMPLX( ONE, ZERO ),
+     $                        F( IS, 1 ), LDF )
+                  CALL ZGEMM( 'N', 'C', MB, JS-1, NB,
+     $                        DCMPLX( ONE, ZERO ), F( IS, JS ), LDF,
+     $                        E( 1, JS ), LDE, DCMPLX( ONE, ZERO ),
+     $                        F( IS, 1 ), LDF )
+               END IF
+               IF( I.LT.P ) THEN
+                  CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
+     $                        DCMPLX( -ONE, ZERO ), A( IS, IE+1 ), LDA,
+     $                        C( IS, JS ), LDC, DCMPLX( ONE, ZERO ),
+     $                        C( IE+1, JS ), LDC )
+                  CALL ZGEMM( 'C', 'N', M-IE, NB, MB,
+     $                        DCMPLX( -ONE, ZERO ), D( IS, IE+1 ), LDD,
+     $                        F( IS, JS ), LDF, DCMPLX( ONE, ZERO ),
+     $                        C( IE+1, JS ), LDC )
+               END IF
+  200       CONTINUE
+  210    CONTINUE
+      END IF
+*
+      WORK( 1 ) = LWMIN
+*
+      RETURN
+*
+*     End of ZTGSYL
+*
+      END
diff --git a/src/lib/lapack/ztrevc.f b/src/lib/lapack/ztrevc.f
new file mode 100644
index 00000000..21142f42
--- /dev/null
+++ b/src/lib/lapack/ztrevc.f
@@ -0,0 +1,386 @@
+      SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+     $                   LDVR, MM, M, WORK, RWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          HOWMNY, SIDE
+      INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      DOUBLE PRECISION   RWORK( * )
+      COMPLEX*16         T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+     $                   WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTREVC computes some or all of the right and/or left eigenvectors of
+*  a complex upper triangular matrix T.
+*  Matrices of this type are produced by the Schur factorization of
+*  a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.
+*  
+*  The right eigenvector x and the left eigenvector y of T corresponding
+*  to an eigenvalue w are defined by:
+*  
+*               T*x = w*x,     (y**H)*T = w*(y**H)
+*  
+*  where y**H denotes the conjugate transpose of the vector y.
+*  The eigenvalues are not input to this routine, but are read directly
+*  from the diagonal of T.
+*  
+*  This routine returns the matrices X and/or Y of right and left
+*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+*  input matrix.  If Q is the unitary factor that reduces a matrix A to
+*  Schur form T, then Q*X and Q*Y are the matrices of right and left
+*  eigenvectors of A.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'R':  compute right eigenvectors only;
+*          = 'L':  compute left eigenvectors only;
+*          = 'B':  compute both right and left eigenvectors.
+*
+*  HOWMNY  (input) CHARACTER*1
+*          = 'A':  compute all right and/or left eigenvectors;
+*          = 'B':  compute all right and/or left eigenvectors,
+*                  backtransformed using the matrices supplied in
+*                  VR and/or VL;
+*          = 'S':  compute selected right and/or left eigenvectors,
+*                  as indicated by the logical array SELECT.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+*          computed.
+*          The eigenvector corresponding to the j-th eigenvalue is
+*          computed if SELECT(j) = .TRUE..
+*          Not referenced if HOWMNY = 'A' or 'B'.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)
+*          The upper triangular matrix T.  T is modified, but restored
+*          on exit.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)
+*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+*          contain an N-by-N matrix Q (usually the unitary matrix Q of
+*          Schur vectors returned by ZHSEQR).
+*          On exit, if SIDE = 'L' or 'B', VL contains:
+*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+*          if HOWMNY = 'B', the matrix Q*Y;
+*          if HOWMNY = 'S', the left eigenvectors of T specified by
+*                           SELECT, stored consecutively in the columns
+*                           of VL, in the same order as their
+*                           eigenvalues.
+*          Not referenced if SIDE = 'R'.
+*
+*  LDVL    (input) INTEGER
+*          The leading dimension of the array VL.  LDVL >= 1, and if
+*          SIDE = 'L' or 'B', LDVL >= N.
+*
+*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)
+*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+*          contain an N-by-N matrix Q (usually the unitary matrix Q of
+*          Schur vectors returned by ZHSEQR).
+*          On exit, if SIDE = 'R' or 'B', VR contains:
+*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+*          if HOWMNY = 'B', the matrix Q*X;
+*          if HOWMNY = 'S', the right eigenvectors of T specified by
+*                           SELECT, stored consecutively in the columns
+*                           of VR, in the same order as their
+*                           eigenvalues.
+*          Not referenced if SIDE = 'L'.
+*
+*  LDVR    (input) INTEGER
+*          The leading dimension of the array VR.  LDVR >= 1, and if
+*          SIDE = 'R' or 'B'; LDVR >= N.
+*
+*  MM      (input) INTEGER
+*          The number of columns in the arrays VL and/or VR. MM >= M.
+*
+*  M       (output) INTEGER
+*          The number of columns in the arrays VL and/or VR actually
+*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
+*          is set to N.  Each selected eigenvector occupies one
+*          column.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)
+*
+*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  The algorithm used in this program is basically backward (forward)
+*  substitution, with scaling to make the the code robust against
+*  possible overflow.
+*
+*  Each eigenvector is normalized so that the element of largest
+*  magnitude has magnitude 1; here the magnitude of a complex number
+*  (x,y) is taken to be |x| + |y|.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+      COMPLEX*16         CMZERO, CMONE
+      PARAMETER          ( CMZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   CMONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV
+      INTEGER            I, II, IS, J, K, KI
+      DOUBLE PRECISION   OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL
+      COMPLEX*16         CDUM
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            IZAMAX
+      DOUBLE PRECISION   DLAMCH, DZASUM
+      EXTERNAL           LSAME, IZAMAX, DLAMCH, DZASUM
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX
+*     ..
+*     .. Statement Functions ..
+      DOUBLE PRECISION   CABS1
+*     ..
+*     .. Statement Function definitions ..
+      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters
+*
+      BOTHV = LSAME( SIDE, 'B' )
+      RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+      LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+      ALLV = LSAME( HOWMNY, 'A' )
+      OVER = LSAME( HOWMNY, 'B' )
+      SOMEV = LSAME( HOWMNY, 'S' )
+*
+*     Set M to the number of columns required to store the selected
+*     eigenvectors.
+*
+      IF( SOMEV ) THEN
+         M = 0
+         DO 10 J = 1, N
+            IF( SELECT( J ) )
+     $         M = M + 1
+   10    CONTINUE
+      ELSE
+         M = N
+      END IF
+*
+      INFO = 0
+      IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+         INFO = -1
+      ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+         INFO = -10
+      ELSE IF( MM.LT.M ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTREVC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Set the constants to control overflow.
+*
+      UNFL = DLAMCH( 'Safe minimum' )
+      OVFL = ONE / UNFL
+      CALL DLABAD( UNFL, OVFL )
+      ULP = DLAMCH( 'Precision' )
+      SMLNUM = UNFL*( N / ULP )
+*
+*     Store the diagonal elements of T in working array WORK.
+*
+      DO 20 I = 1, N
+         WORK( I+N ) = T( I, I )
+   20 CONTINUE
+*
+*     Compute 1-norm of each column of strictly upper triangular
+*     part of T to control overflow in triangular solver.
+*
+      RWORK( 1 ) = ZERO
+      DO 30 J = 2, N
+         RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 )
+   30 CONTINUE
+*
+      IF( RIGHTV ) THEN
+*
+*        Compute right eigenvectors.
+*
+         IS = M
+         DO 80 KI = N, 1, -1
+*
+            IF( SOMEV ) THEN
+               IF( .NOT.SELECT( KI ) )
+     $            GO TO 80
+            END IF
+            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
+*
+            WORK( 1 ) = CMONE
+*
+*           Form right-hand side.
+*
+            DO 40 K = 1, KI - 1
+               WORK( K ) = -T( K, KI )
+   40       CONTINUE
+*
+*           Solve the triangular system:
+*              (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
+*
+            DO 50 K = 1, KI - 1
+               T( K, K ) = T( K, K ) - T( KI, KI )
+               IF( CABS1( T( K, K ) ).LT.SMIN )
+     $            T( K, K ) = SMIN
+   50       CONTINUE
+*
+            IF( KI.GT.1 ) THEN
+               CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y',
+     $                      KI-1, T, LDT, WORK( 1 ), SCALE, RWORK,
+     $                      INFO )
+               WORK( KI ) = SCALE
+            END IF
+*
+*           Copy the vector x or Q*x to VR and normalize.
+*
+            IF( .NOT.OVER ) THEN
+               CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 )
+*
+               II = IZAMAX( KI, VR( 1, IS ), 1 )
+               REMAX = ONE / CABS1( VR( II, IS ) )
+               CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+               DO 60 K = KI + 1, N
+                  VR( K, IS ) = CMZERO
+   60          CONTINUE
+            ELSE
+               IF( KI.GT.1 )
+     $            CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ),
+     $                        1, DCMPLX( SCALE ), VR( 1, KI ), 1 )
+*
+               II = IZAMAX( N, VR( 1, KI ), 1 )
+               REMAX = ONE / CABS1( VR( II, KI ) )
+               CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 )
+            END IF
+*
+*           Set back the original diagonal elements of T.
+*
+            DO 70 K = 1, KI - 1
+               T( K, K ) = WORK( K+N )
+   70       CONTINUE
+*
+            IS = IS - 1
+   80    CONTINUE
+      END IF
+*
+      IF( LEFTV ) THEN
+*
+*        Compute left eigenvectors.
+*
+         IS = 1
+         DO 130 KI = 1, N
+*
+            IF( SOMEV ) THEN
+               IF( .NOT.SELECT( KI ) )
+     $            GO TO 130
+            END IF
+            SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM )
+*
+            WORK( N ) = CMONE
+*
+*           Form right-hand side.
+*
+            DO 90 K = KI + 1, N
+               WORK( K ) = -DCONJG( T( KI, K ) )
+   90       CONTINUE
+*
+*           Solve the triangular system:
+*              (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK.
+*
+            DO 100 K = KI + 1, N
+               T( K, K ) = T( K, K ) - T( KI, KI )
+               IF( CABS1( T( K, K ) ).LT.SMIN )
+     $            T( K, K ) = SMIN
+  100       CONTINUE
+*
+            IF( KI.LT.N ) THEN
+               CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit',
+     $                      'Y', N-KI, T( KI+1, KI+1 ), LDT,
+     $                      WORK( KI+1 ), SCALE, RWORK, INFO )
+               WORK( KI ) = SCALE
+            END IF
+*
+*           Copy the vector x or Q*x to VL and normalize.
+*
+            IF( .NOT.OVER ) THEN
+               CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 )
+*
+               II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+               REMAX = ONE / CABS1( VL( II, IS ) )
+               CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+*
+               DO 110 K = 1, KI - 1
+                  VL( K, IS ) = CMZERO
+  110          CONTINUE
+            ELSE
+               IF( KI.LT.N )
+     $            CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL,
+     $                        WORK( KI+1 ), 1, DCMPLX( SCALE ),
+     $                        VL( 1, KI ), 1 )
+*
+               II = IZAMAX( N, VL( 1, KI ), 1 )
+               REMAX = ONE / CABS1( VL( II, KI ) )
+               CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 )
+            END IF
+*
+*           Set back the original diagonal elements of T.
+*
+            DO 120 K = KI + 1, N
+               T( K, K ) = WORK( K+N )
+  120       CONTINUE
+*
+            IS = IS + 1
+  130    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZTREVC
+*
+      END
diff --git a/src/lib/lapack/ztrexc.f b/src/lib/lapack/ztrexc.f
new file mode 100644
index 00000000..69313696
--- /dev/null
+++ b/src/lib/lapack/ztrexc.f
@@ -0,0 +1,162 @@
+      SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ
+      INTEGER            IFST, ILST, INFO, LDQ, LDT, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         Q( LDQ, * ), T( LDT, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTREXC reorders the Schur factorization of a complex matrix
+*  A = Q*T*Q**H, so that the diagonal element of T with row index IFST
+*  is moved to row ILST.
+*
+*  The Schur form T is reordered by a unitary similarity transformation
+*  Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
+*  postmultplying it with Z.
+*
+*  Arguments
+*  =========
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'V':  update the matrix Q of Schur vectors;
+*          = 'N':  do not update Q.
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)
+*          On entry, the upper triangular matrix T.
+*          On exit, the reordered upper triangular matrix.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+*          On exit, if COMPQ = 'V', Q has been postmultiplied by the
+*          unitary transformation matrix Z which reorders T.
+*          If COMPQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.  LDQ >= max(1,N).
+*
+*  IFST    (input) INTEGER
+*  ILST    (input) INTEGER
+*          Specify the reordering of the diagonal elements of T:
+*          The element with row index IFST is moved to row ILST by a
+*          sequence of transpositions between adjacent elements.
+*          1 <= IFST <= N; 1 <= ILST <= N.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            WANTQ
+      INTEGER            K, M1, M2, M3
+      DOUBLE PRECISION   CS
+      COMPLEX*16         SN, T11, T22, TEMP
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARTG, ZROT
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters.
+*
+      INFO = 0
+      WANTQ = LSAME( COMPQ, 'V' )
+      IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
+         INFO = -6
+      ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+         INFO = -7
+      ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTREXC', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.1 .OR. IFST.EQ.ILST )
+     $   RETURN
+*
+      IF( IFST.LT.ILST ) THEN
+*
+*        Move the IFST-th diagonal element forward down the diagonal.
+*
+         M1 = 0
+         M2 = -1
+         M3 = 1
+      ELSE
+*
+*        Move the IFST-th diagonal element backward up the diagonal.
+*
+         M1 = -1
+         M2 = 0
+         M3 = -1
+      END IF
+*
+      DO 10 K = IFST + M1, ILST + M2, M3
+*
+*        Interchange the k-th and (k+1)-th diagonal elements.
+*
+         T11 = T( K, K )
+         T22 = T( K+1, K+1 )
+*
+*        Determine the transformation to perform the interchange.
+*
+         CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP )
+*
+*        Apply transformation to the matrix T.
+*
+         IF( K+2.LE.N )
+     $      CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS,
+     $                 SN )
+         CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS,
+     $              DCONJG( SN ) )
+*
+         T( K, K ) = T22
+         T( K+1, K+1 ) = T11
+*
+         IF( WANTQ ) THEN
+*
+*           Accumulate transformation in the matrix Q.
+*
+            CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS,
+     $                 DCONJG( SN ) )
+         END IF
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of ZTREXC
+*
+      END
diff --git a/src/lib/lapack/ztrsen.f b/src/lib/lapack/ztrsen.f
new file mode 100644
index 00000000..a07a22f6
--- /dev/null
+++ b/src/lib/lapack/ztrsen.f
@@ -0,0 +1,359 @@
+      SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S,
+     $                   SEP, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     Modified to call ZLACN2 in place of ZLACON, 10 Feb 03, SJH.
+*
+*     .. Scalar Arguments ..
+      CHARACTER          COMPQ, JOB
+      INTEGER            INFO, LDQ, LDT, LWORK, M, N
+      DOUBLE PRECISION   S, SEP
+*     ..
+*     .. Array Arguments ..
+      LOGICAL            SELECT( * )
+      COMPLEX*16         Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRSEN reorders the Schur factorization of a complex matrix
+*  A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
+*  the leading positions on the diagonal of the upper triangular matrix
+*  T, and the leading columns of Q form an orthonormal basis of the
+*  corresponding right invariant subspace.
+*
+*  Optionally the routine computes the reciprocal condition numbers of
+*  the cluster of eigenvalues and/or the invariant subspace.
+*
+*  Arguments
+*  =========
+*
+*  JOB     (input) CHARACTER*1
+*          Specifies whether condition numbers are required for the
+*          cluster of eigenvalues (S) or the invariant subspace (SEP):
+*          = 'N': none;
+*          = 'E': for eigenvalues only (S);
+*          = 'V': for invariant subspace only (SEP);
+*          = 'B': for both eigenvalues and invariant subspace (S and
+*                 SEP).
+*
+*  COMPQ   (input) CHARACTER*1
+*          = 'V': update the matrix Q of Schur vectors;
+*          = 'N': do not update Q.
+*
+*  SELECT  (input) LOGICAL array, dimension (N)
+*          SELECT specifies the eigenvalues in the selected cluster. To
+*          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
+*
+*  N       (input) INTEGER
+*          The order of the matrix T. N >= 0.
+*
+*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)
+*          On entry, the upper triangular matrix T.
+*          On exit, T is overwritten by the reordered matrix T, with the
+*          selected eigenvalues as the leading diagonal elements.
+*
+*  LDT     (input) INTEGER
+*          The leading dimension of the array T. LDT >= max(1,N).
+*
+*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)
+*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+*          On exit, if COMPQ = 'V', Q has been postmultiplied by the
+*          unitary transformation matrix which reorders T; the leading M
+*          columns of Q form an orthonormal basis for the specified
+*          invariant subspace.
+*          If COMPQ = 'N', Q is not referenced.
+*
+*  LDQ     (input) INTEGER
+*          The leading dimension of the array Q.
+*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
+*
+*  W       (output) COMPLEX*16 array, dimension (N)
+*          The reordered eigenvalues of T, in the same order as they
+*          appear on the diagonal of T.
+*
+*  M       (output) INTEGER
+*          The dimension of the specified invariant subspace.
+*          0 <= M <= N.
+*
+*  S       (output) DOUBLE PRECISION
+*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+*          condition number for the selected cluster of eigenvalues.
+*          S cannot underestimate the true reciprocal condition number
+*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+*          If JOB = 'N' or 'V', S is not referenced.
+*
+*  SEP     (output) DOUBLE PRECISION
+*          If JOB = 'V' or 'B', SEP is the estimated reciprocal
+*          condition number of the specified invariant subspace. If
+*          M = 0 or N, SEP = norm(T).
+*          If JOB = 'N' or 'E', SEP is not referenced.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If JOB = 'N', LWORK >= 1;
+*          if JOB = 'E', LWORK = max(1,M*(N-M));
+*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  ZTRSEN first collects the selected eigenvalues by computing a unitary
+*  transformation Z to move them to the top left corner of T. In other
+*  words, the selected eigenvalues are the eigenvalues of T11 in:
+*
+*                Z'*T*Z = ( T11 T12 ) n1
+*                         (  0  T22 ) n2
+*                            n1  n2
+*
+*  where N = n1+n2 and Z' means the conjugate transpose of Z. The first
+*  n1 columns of Z span the specified invariant subspace of T.
+*
+*  If T has been obtained from the Schur factorization of a matrix
+*  A = Q*T*Q', then the reordered Schur factorization of A is given by
+*  A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the
+*  corresponding invariant subspace of A.
+*
+*  The reciprocal condition number of the average of the eigenvalues of
+*  T11 may be returned in S. S lies between 0 (very badly conditioned)
+*  and 1 (very well conditioned). It is computed as follows. First we
+*  compute R so that
+*
+*                         P = ( I  R ) n1
+*                             ( 0  0 ) n2
+*                               n1 n2
+*
+*  is the projector on the invariant subspace associated with T11.
+*  R is the solution of the Sylvester equation:
+*
+*                        T11*R - R*T22 = T12.
+*
+*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
+*  the two-norm of M. Then S is computed as the lower bound
+*
+*                      (1 + F-norm(R)**2)**(-1/2)
+*
+*  on the reciprocal of 2-norm(P), the true reciprocal condition number.
+*  S cannot underestimate 1 / 2-norm(P) by more than a factor of
+*  sqrt(N).
+*
+*  An approximate error bound for the computed average of the
+*  eigenvalues of T11 is
+*
+*                         EPS * norm(T) / S
+*
+*  where EPS is the machine precision.
+*
+*  The reciprocal condition number of the right invariant subspace
+*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
+*  SEP is defined as the separation of T11 and T22:
+*
+*                     sep( T11, T22 ) = sigma-min( C )
+*
+*  where sigma-min(C) is the smallest singular value of the
+*  n1*n2-by-n1*n2 matrix
+*
+*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
+*
+*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
+*  product. We estimate sigma-min(C) by the reciprocal of an estimate of
+*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
+*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
+*
+*  When SEP is small, small changes in T can cause large changes in
+*  the invariant subspace. An approximate bound on the maximum angular
+*  error in the computed right invariant subspace is
+*
+*                      EPS * norm(T) / SEP
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, ONE
+      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTBH, WANTQ, WANTS, WANTSP
+      INTEGER            IERR, K, KASE, KS, LWMIN, N1, N2, NN
+      DOUBLE PRECISION   EST, RNORM, SCALE
+*     ..
+*     .. Local Arrays ..
+      INTEGER            ISAVE( 3 )
+      DOUBLE PRECISION   RWORK( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   ZLANGE
+      EXTERNAL           LSAME, ZLANGE
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACN2, ZLACPY, ZTREXC, ZTRSYL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and test the input parameters.
+*
+      WANTBH = LSAME( JOB, 'B' )
+      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+      WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+      WANTQ = LSAME( COMPQ, 'V' )
+*
+*     Set M to the number of selected eigenvalues.
+*
+      M = 0
+      DO 10 K = 1, N
+         IF( SELECT( K ) )
+     $      M = M + 1
+   10 CONTINUE
+*
+      N1 = M
+      N2 = N - M
+      NN = N1*N2
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+*
+      IF( WANTSP ) THEN
+         LWMIN = MAX( 1, 2*NN )
+      ELSE IF( LSAME( JOB, 'N' ) ) THEN
+         LWMIN = 1
+      ELSE IF( LSAME( JOB, 'E' ) ) THEN
+         LWMIN = MAX( 1, NN )
+      END IF
+*
+      IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+     $     THEN
+         INFO = -1
+      ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+         INFO = -6
+      ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+         INFO = -8
+      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+         INFO = -14
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         WORK( 1 ) = LWMIN
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRSEN', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.N .OR. M.EQ.0 ) THEN
+         IF( WANTS )
+     $      S = ONE
+         IF( WANTSP )
+     $      SEP = ZLANGE( '1', N, N, T, LDT, RWORK )
+         GO TO 40
+      END IF
+*
+*     Collect the selected eigenvalues at the top left corner of T.
+*
+      KS = 0
+      DO 20 K = 1, N
+         IF( SELECT( K ) ) THEN
+            KS = KS + 1
+*
+*           Swap the K-th eigenvalue to position KS.
+*
+            IF( K.NE.KS )
+     $         CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR )
+         END IF
+   20 CONTINUE
+*
+      IF( WANTS ) THEN
+*
+*        Solve the Sylvester equation for R:
+*
+*           T11*R - R*T22 = scale*T12
+*
+         CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+         CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
+     $                LDT, WORK, N1, SCALE, IERR )
+*
+*        Estimate the reciprocal of the condition number of the cluster
+*        of eigenvalues.
+*
+         RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK )
+         IF( RNORM.EQ.ZERO ) THEN
+            S = ONE
+         ELSE
+            S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
+     $          SQRT( RNORM ) )
+         END IF
+      END IF
+*
+      IF( WANTSP ) THEN
+*
+*        Estimate sep(T11,T22).
+*
+         EST = ZERO
+         KASE = 0
+   30    CONTINUE
+         CALL ZLACN2( NN, WORK( NN+1 ), WORK, EST, KASE, ISAVE )
+         IF( KASE.NE.0 ) THEN
+            IF( KASE.EQ.1 ) THEN
+*
+*              Solve T11*R - R*T22 = scale*X.
+*
+               CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
+     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+     $                      IERR )
+            ELSE
+*
+*              Solve T11'*R - R*T22' = scale*X.
+*
+               CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT,
+     $                      T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+     $                      IERR )
+            END IF
+            GO TO 30
+         END IF
+*
+         SEP = SCALE / EST
+      END IF
+*
+   40 CONTINUE
+*
+*     Copy reordered eigenvalues to W.
+*
+      DO 50 K = 1, N
+         W( K ) = T( K, K )
+   50 CONTINUE
+*
+      WORK( 1 ) = LWMIN
+*
+      RETURN
+*
+*     End of ZTRSEN
+*
+      END
diff --git a/src/lib/lapack/ztrsyl.f b/src/lib/lapack/ztrsyl.f
new file mode 100644
index 00000000..d2e0ecc7
--- /dev/null
+++ b/src/lib/lapack/ztrsyl.f
@@ -0,0 +1,365 @@
+      SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+     $                   LDC, SCALE, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          TRANA, TRANB
+      INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
+      DOUBLE PRECISION   SCALE
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRSYL solves the complex Sylvester matrix equation:
+*
+*     op(A)*X + X*op(B) = scale*C or
+*     op(A)*X - X*op(B) = scale*C,
+*
+*  where op(A) = A or A**H, and A and B are both upper triangular. A is
+*  M-by-M and B is N-by-N; the right hand side C and the solution X are
+*  M-by-N; and scale is an output scale factor, set <= 1 to avoid
+*  overflow in X.
+*
+*  Arguments
+*  =========
+*
+*  TRANA   (input) CHARACTER*1
+*          Specifies the option op(A):
+*          = 'N': op(A) = A    (No transpose)
+*          = 'C': op(A) = A**H (Conjugate transpose)
+*
+*  TRANB   (input) CHARACTER*1
+*          Specifies the option op(B):
+*          = 'N': op(B) = B    (No transpose)
+*          = 'C': op(B) = B**H (Conjugate transpose)
+*
+*  ISGN    (input) INTEGER
+*          Specifies the sign in the equation:
+*          = +1: solve op(A)*X + X*op(B) = scale*C
+*          = -1: solve op(A)*X - X*op(B) = scale*C
+*
+*  M       (input) INTEGER
+*          The order of the matrix A, and the number of rows in the
+*          matrices X and C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The order of the matrix B, and the number of columns in the
+*          matrices X and C. N >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,M)
+*          The upper triangular matrix A.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,M).
+*
+*  B       (input) COMPLEX*16 array, dimension (LDB,N)
+*          The upper triangular matrix B.
+*
+*  LDB     (input) INTEGER
+*          The leading dimension of the array B. LDB >= max(1,N).
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N right hand side matrix C.
+*          On exit, C is overwritten by the solution matrix X.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M)
+*
+*  SCALE   (output) DOUBLE PRECISION
+*          The scale factor, scale, set <= 1 to avoid overflow in X.
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          = 1: A and B have common or very close eigenvalues; perturbed
+*               values were used to solve the equation (but the matrices
+*               A and B are unchanged).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE
+      PARAMETER          ( ONE = 1.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOTRNA, NOTRNB
+      INTEGER            J, K, L
+      DOUBLE PRECISION   BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+     $                   SMLNUM
+      COMPLEX*16         A11, SUML, SUMR, VEC, X11
+*     ..
+*     .. Local Arrays ..
+      DOUBLE PRECISION   DUM( 1 )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      DOUBLE PRECISION   DLAMCH, ZLANGE
+      COMPLEX*16         ZDOTC, ZDOTU, ZLADIV
+      EXTERNAL           LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU, ZLADIV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           DLABAD, XERBLA, ZDSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Decode and Test input parameters
+*
+      NOTRNA = LSAME( TRANA, 'N' )
+      NOTRNB = LSAME( TRANB, 'N' )
+*
+      INFO = 0
+      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -7
+      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+         INFO = -9
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRSYL', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+*     Set constants to control overflow
+*
+      EPS = DLAMCH( 'P' )
+      SMLNUM = DLAMCH( 'S' )
+      BIGNUM = ONE / SMLNUM
+      CALL DLABAD( SMLNUM, BIGNUM )
+      SMLNUM = SMLNUM*DBLE( M*N ) / EPS
+      BIGNUM = ONE / SMLNUM
+      SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ),
+     $       EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) )
+      SCALE = ONE
+      SGN = ISGN
+*
+      IF( NOTRNA .AND. NOTRNB ) THEN
+*
+*        Solve    A*X + ISGN*X*B = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        bottom-left corner column by column by
+*
+*            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                    M                        L-1
+*          R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
+*                  I=K+1                      J=1
+*
+         DO 30 L = 1, N
+            DO 20 K = M, 1, -1
+*
+               SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
+     $                C( MIN( K+1, M ), L ), 1 )
+               SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
+               VEC = C( K, L ) - ( SUML+SGN*SUMR )
+*
+               SCALOC = ONE
+               A11 = A( K, K ) + SGN*B( L, L )
+               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 10 J = 1, N
+                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
+   10             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+               C( K, L ) = X11
+*
+   20       CONTINUE
+   30    CONTINUE
+*
+      ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
+*
+*        Solve    A' *X + ISGN*X*B = scale*C.
+*
+*        The (K,L)th block of X is determined starting from
+*        upper-left corner column by column by
+*
+*            A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                   K-1                         L-1
+*          R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
+*                   I=1                         J=1
+*
+         DO 60 L = 1, N
+            DO 50 K = 1, M
+*
+               SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
+               SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 )
+               VEC = C( K, L ) - ( SUML+SGN*SUMR )
+*
+               SCALOC = ONE
+               A11 = DCONJG( A( K, K ) ) + SGN*B( L, L )
+               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 40 J = 1, N
+                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
+   40             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+               C( K, L ) = X11
+*
+   50       CONTINUE
+   60    CONTINUE
+*
+      ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+*        Solve    A'*X + ISGN*X*B' = C.
+*
+*        The (K,L)th block of X is determined starting from
+*        upper-right corner column by column by
+*
+*            A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                    K-1
+*           R(K,L) = SUM [A'(I,K)*X(I,L)] +
+*                    I=1
+*                           N
+*                     ISGN*SUM [X(K,J)*B'(L,J)].
+*                          J=L+1
+*
+         DO 90 L = N, 1, -1
+            DO 80 K = 1, M
+*
+               SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
+               SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
+     $                B( L, MIN( L+1, N ) ), LDB )
+               VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
+*
+               SCALOC = ONE
+               A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
+               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 70 J = 1, N
+                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
+   70             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+               C( K, L ) = X11
+*
+   80       CONTINUE
+   90    CONTINUE
+*
+      ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+*        Solve    A*X + ISGN*X*B' = C.
+*
+*        The (K,L)th block of X is determined starting from
+*        bottom-left corner column by column by
+*
+*           A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
+*
+*        Where
+*                    M                          N
+*          R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
+*                  I=K+1                      J=L+1
+*
+         DO 120 L = N, 1, -1
+            DO 110 K = M, 1, -1
+*
+               SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
+     $                C( MIN( K+1, M ), L ), 1 )
+               SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
+     $                B( L, MIN( L+1, N ) ), LDB )
+               VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
+*
+               SCALOC = ONE
+               A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
+               DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
+               IF( DA11.LE.SMIN ) THEN
+                  A11 = SMIN
+                  DA11 = SMIN
+                  INFO = 1
+               END IF
+               DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
+               IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+                  IF( DB.GT.BIGNUM*DA11 )
+     $               SCALOC = ONE / DB
+               END IF
+*
+               X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
+*
+               IF( SCALOC.NE.ONE ) THEN
+                  DO 100 J = 1, N
+                     CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
+  100             CONTINUE
+                  SCALE = SCALE*SCALOC
+               END IF
+               C( K, L ) = X11
+*
+  110       CONTINUE
+  120    CONTINUE
+*
+      END IF
+*
+      RETURN
+*
+*     End of ZTRSYL
+*
+      END
diff --git a/src/lib/lapack/ztrti2.f b/src/lib/lapack/ztrti2.f
new file mode 100644
index 00000000..73c7bbc3
--- /dev/null
+++ b/src/lib/lapack/ztrti2.f
@@ -0,0 +1,146 @@
+      SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRTI2 computes the inverse of a complex upper or lower triangular
+*  matrix.
+*
+*  This is the Level 2 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          Specifies whether the matrix A is upper or lower triangular.
+*          = 'U':  Upper triangular
+*          = 'L':  Lower triangular
+*
+*  DIAG    (input) CHARACTER*1
+*          Specifies whether or not the matrix A is unit triangular.
+*          = 'N':  Non-unit triangular
+*          = 'U':  Unit triangular
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the triangular matrix A.  If UPLO = 'U', the
+*          leading n by n upper triangular part of the array A contains
+*          the upper triangular matrix, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading n by n lower triangular part of the array A contains
+*          the lower triangular matrix, and the strictly upper
+*          triangular part of A is not referenced.  If DIAG = 'U', the
+*          diagonal elements of A are also not referenced and are
+*          assumed to be 1.
+*
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same storage format.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -k, the k-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J
+      COMPLEX*16         AJJ
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZSCAL, ZTRMV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRTI2', -INFO )
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Compute inverse of upper triangular matrix.
+*
+         DO 10 J = 1, N
+            IF( NOUNIT ) THEN
+               A( J, J ) = ONE / A( J, J )
+               AJJ = -A( J, J )
+            ELSE
+               AJJ = -ONE
+            END IF
+*
+*           Compute elements 1:j-1 of j-th column.
+*
+            CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+     $                  A( 1, J ), 1 )
+            CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 )
+   10    CONTINUE
+      ELSE
+*
+*        Compute inverse of lower triangular matrix.
+*
+         DO 20 J = N, 1, -1
+            IF( NOUNIT ) THEN
+               A( J, J ) = ONE / A( J, J )
+               AJJ = -A( J, J )
+            ELSE
+               AJJ = -ONE
+            END IF
+            IF( J.LT.N ) THEN
+*
+*              Compute elements j+1:n of j-th column.
+*
+               CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J,
+     $                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+               CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 )
+            END IF
+   20    CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of ZTRTI2
+*
+      END
diff --git a/src/lib/lapack/ztrtri.f b/src/lib/lapack/ztrtri.f
new file mode 100644
index 00000000..7caa9771
--- /dev/null
+++ b/src/lib/lapack/ztrtri.f
@@ -0,0 +1,177 @@
+      SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          DIAG, UPLO
+      INTEGER            INFO, LDA, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTRTRI computes the inverse of a complex upper or lower triangular
+*  matrix A.
+*
+*  This is the Level 3 BLAS version of the algorithm.
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U':  A is upper triangular;
+*          = 'L':  A is lower triangular.
+*
+*  DIAG    (input) CHARACTER*1
+*          = 'N':  A is non-unit triangular;
+*          = 'U':  A is unit triangular.
+*
+*  N       (input) INTEGER
+*          The order of the matrix A.  N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the triangular matrix A.  If UPLO = 'U', the
+*          leading N-by-N upper triangular part of the array A contains
+*          the upper triangular matrix, and the strictly lower
+*          triangular part of A is not referenced.  If UPLO = 'L', the
+*          leading N-by-N lower triangular part of the array A contains
+*          the lower triangular matrix, and the strictly upper
+*          triangular part of A is not referenced.  If DIAG = 'U', the
+*          diagonal elements of A are also not referenced and are
+*          assumed to be 1.
+*          On exit, the (triangular) inverse of the original matrix, in
+*          the same storage format.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,N).
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
+*               matrix is singular and its inverse can not be computed.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            NOUNIT, UPPER
+      INTEGER            J, JB, NB, NN
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZTRMM, ZTRSM, ZTRTI2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      UPPER = LSAME( UPLO, 'U' )
+      NOUNIT = LSAME( DIAG, 'N' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTRTRI', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 )
+     $   RETURN
+*
+*     Check for singularity if non-unit.
+*
+      IF( NOUNIT ) THEN
+         DO 10 INFO = 1, N
+            IF( A( INFO, INFO ).EQ.ZERO )
+     $         RETURN
+   10    CONTINUE
+         INFO = 0
+      END IF
+*
+*     Determine the block size for this environment.
+*
+      NB = ILAENV( 1, 'ZTRTRI', UPLO // DIAG, N, -1, -1, -1 )
+      IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( UPPER ) THEN
+*
+*           Compute inverse of upper triangular matrix
+*
+            DO 20 J = 1, N, NB
+               JB = MIN( NB, N-J+1 )
+*
+*              Compute rows 1:j-1 of current block column
+*
+               CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, ONE, A, LDA, A( 1, J ), LDA )
+               CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+     $                     JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+*              Compute inverse of current diagonal block
+*
+               CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
+   20       CONTINUE
+         ELSE
+*
+*           Compute inverse of lower triangular matrix
+*
+            NN = ( ( N-1 ) / NB )*NB + 1
+            DO 30 J = NN, 1, -NB
+               JB = MIN( NB, N-J+1 )
+               IF( J+JB.LE.N ) THEN
+*
+*                 Compute rows j+jb:n of current block column
+*
+                  CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+     $                        A( J+JB, J ), LDA )
+                  CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG,
+     $                        N-J-JB+1, JB, -ONE, A( J, J ), LDA,
+     $                        A( J+JB, J ), LDA )
+               END IF
+*
+*              Compute inverse of current diagonal block
+*
+               CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+   30       CONTINUE
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZTRTRI
+*
+      END
diff --git a/src/lib/lapack/ztzrzf.f b/src/lib/lapack/ztzrzf.f
new file mode 100644
index 00000000..5c9c6543
--- /dev/null
+++ b/src/lib/lapack/ztzrzf.f
@@ -0,0 +1,244 @@
+      SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
+*  to upper triangular form by means of unitary transformations.
+*
+*  The upper trapezoidal matrix A is factored as
+*
+*     A = ( R  0 ) * Z,
+*
+*  where Z is an N-by-N unitary matrix and R is an M-by-M upper
+*  triangular matrix.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix A.  M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix A.  N >= M.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the leading M-by-N upper trapezoidal part of the
+*          array A must contain the matrix to be factorized.
+*          On exit, the leading M-by-M upper triangular part of A
+*          contains the upper triangular matrix R, and elements M+1 to
+*          N of the first M rows of A, with the array TAU, represent the
+*          unitary matrix Z as a product of M elementary reflectors.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.  LDA >= max(1,M).
+*
+*  TAU     (output) COMPLEX*16 array, dimension (M)
+*          The scalar factors of the elementary reflectors.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.  LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  The factorization is obtained by Householder's method.  The kth
+*  transformation matrix, Z( k ), which is used to introduce zeros into
+*  the ( m - k + 1 )th row of A, is given in the form
+*
+*     Z( k ) = ( I     0   ),
+*              ( 0  T( k ) )
+*
+*  where
+*
+*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),
+*                                                 (   0    )
+*                                                 ( z( k ) )
+*
+*  tau is a scalar and z( k ) is an ( n - m ) element vector.
+*  tau and z( k ) are chosen to annihilate the elements of the kth row
+*  of X.
+*
+*  The scalar tau is returned in the kth element of TAU and the vector
+*  u( k ) in the kth row of A, such that the elements of z( k ) are
+*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+*  the upper triangular part of A.
+*
+*  Z is given by
+*
+*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+     $                   NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARZB, ZLARZT, ZLATRZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -4
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. M.EQ.N ) THEN
+            LWKOPT = 1
+         ELSE
+*
+*           Determine the block size.
+*
+            NB = ILAENV( 1, 'ZGERQF', ' ', M, N, -1, -1 )
+            LWKOPT = M*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+            INFO = -7
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZTZRZF', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 ) THEN
+         RETURN
+      ELSE IF( M.EQ.N ) THEN
+         DO 10 I = 1, N
+            TAU( I ) = ZERO
+   10    CONTINUE
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 1
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.M ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZGERQF', ' ', M, N, -1, -1 ) )
+         IF( NX.LT.M ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZGERQF', ' ', M, N, -1,
+     $                 -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
+*
+*        Use blocked code initially.
+*        The last kk rows are handled by the block method.
+*
+         M1 = MIN( M+1, N )
+         KI = ( ( M-NX-1 ) / NB )*NB
+         KK = MIN( M, KI+NB )
+*
+         DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
+            IB = MIN( M-I+1, NB )
+*
+*           Compute the TZ factorization of the current block
+*           A(i:i+ib-1,i:n)
+*
+            CALL ZLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
+     $                   WORK )
+            IF( I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL ZLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(1:i-1,i:n) from the right
+*
+               CALL ZLARZB( 'Right', 'No transpose', 'Backward',
+     $                      'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
+     $                      LDA, WORK, LDWORK, A( 1, I ), LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+   20    CONTINUE
+         MU = I + NB - 1
+      ELSE
+         MU = M
+      END IF
+*
+*     Use unblocked code to factor the last or only block
+*
+      IF( MU.GT.0 )
+     $   CALL ZLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZTZRZF
+*
+      END
diff --git a/src/lib/lapack/zung2l.f b/src/lib/lapack/zung2l.f
new file mode 100644
index 00000000..29178b90
--- /dev/null
+++ b/src/lib/lapack/zung2l.f
@@ -0,0 +1,128 @@
+      SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
+*  which is defined as the last n columns of a product of k elementary
+*  reflectors of order m
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by ZGEQLF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the (n-k+i)-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGEQLF in the last k columns of its array
+*          argument A.
+*          On exit, the m-by-n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQLF.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, II, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNG2L', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Initialise columns 1:n-k to columns of the unit matrix
+*
+      DO 20 J = 1, N - K
+         DO 10 L = 1, M
+            A( L, J ) = ZERO
+   10    CONTINUE
+         A( M-N+J, J ) = ONE
+   20 CONTINUE
+*
+      DO 40 I = 1, K
+         II = N - K + I
+*
+*        Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
+*
+         A( M-N+II, II ) = ONE
+         CALL ZLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+     $               LDA, WORK )
+         CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
+         A( M-N+II, II ) = ONE - TAU( I )
+*
+*        Set A(m-k+i+1:m,n-k+i) to zero
+*
+         DO 30 L = M - N + II + 1, M
+            A( L, II ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of ZUNG2L
+*
+      END
diff --git a/src/lib/lapack/zung2r.f b/src/lib/lapack/zung2r.f
new file mode 100644
index 00000000..cd89f26e
--- /dev/null
+++ b/src/lib/lapack/zung2r.f
@@ -0,0 +1,130 @@
+      SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
+*  which is defined as the first n columns of a product of k elementary
+*  reflectors of order m
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by ZGEQRF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the i-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGEQRF in the first k columns of its array
+*          argument A.
+*          On exit, the m by n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQRF.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (N)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNG2R', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 )
+     $   RETURN
+*
+*     Initialise columns k+1:n to columns of the unit matrix
+*
+      DO 20 J = K + 1, N
+         DO 10 L = 1, M
+            A( L, J ) = ZERO
+   10    CONTINUE
+         A( J, J ) = ONE
+   20 CONTINUE
+*
+      DO 40 I = K, 1, -1
+*
+*        Apply H(i) to A(i:m,i:n) from the left
+*
+         IF( I.LT.N ) THEN
+            A( I, I ) = ONE
+            CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+     $                  A( I, I+1 ), LDA, WORK )
+         END IF
+         IF( I.LT.M )
+     $      CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
+         A( I, I ) = ONE - TAU( I )
+*
+*        Set A(1:i-1,i) to zero
+*
+         DO 30 L = 1, I - 1
+            A( L, I ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of ZUNG2R
+*
+      END
diff --git a/src/lib/lapack/zungbr.f b/src/lib/lapack/zungbr.f
new file mode 100644
index 00000000..94f74820
--- /dev/null
+++ b/src/lib/lapack/zungbr.f
@@ -0,0 +1,245 @@
+      SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          VECT
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGBR generates one of the complex unitary matrices Q or P**H
+*  determined by ZGEBRD when reducing a complex matrix A to bidiagonal
+*  form: A = Q * B * P**H.  Q and P**H are defined as products of
+*  elementary reflectors H(i) or G(i) respectively.
+*
+*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
+*  is of order M:
+*  if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
+*  columns of Q, where m >= n >= k;
+*  if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
+*  M-by-M matrix.
+*
+*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
+*  is of order N:
+*  if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
+*  rows of P**H, where n >= m >= k;
+*  if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
+*  an N-by-N matrix.
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          Specifies whether the matrix Q or the matrix P**H is
+*          required, as defined in the transformation applied by ZGEBRD:
+*          = 'Q':  generate Q;
+*          = 'P':  generate P**H.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q or P**H to be returned.
+*          M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q or P**H to be returned.
+*          N >= 0.
+*          If VECT = 'Q', M >= N >= min(M,K);
+*          if VECT = 'P', N >= M >= min(N,K).
+*
+*  K       (input) INTEGER
+*          If VECT = 'Q', the number of columns in the original M-by-K
+*          matrix reduced by ZGEBRD.
+*          If VECT = 'P', the number of rows in the original K-by-N
+*          matrix reduced by ZGEBRD.
+*          K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by ZGEBRD.
+*          On exit, the M-by-N matrix Q or P**H.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= M.
+*
+*  TAU     (input) COMPLEX*16 array, dimension
+*                                (min(M,K)) if VECT = 'Q'
+*                                (min(N,K)) if VECT = 'P'
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i) or G(i), which determines Q or P**H, as
+*          returned by ZGEBRD in its array argument TAUQ or TAUP.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,min(M,N)).
+*          For optimum performance LWORK >= min(M,N)*NB, where NB
+*          is the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, WANTQ
+      INTEGER            I, IINFO, J, LWKOPT, MN, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNGLQ, ZUNGQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      WANTQ = LSAME( VECT, 'Q' )
+      MN = MIN( M, N )
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+         INFO = -1
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
+     $         K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
+     $         MIN( N, K ) ) ) ) THEN
+         INFO = -3
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -6
+      ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
+         INFO = -9
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( WANTQ ) THEN
+            NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
+         ELSE
+            NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
+         END IF
+         LWKOPT = MAX( 1, MN )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGBR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( WANTQ ) THEN
+*
+*        Form Q, determined by a call to ZGEBRD to reduce an m-by-k
+*        matrix
+*
+         IF( M.GE.K ) THEN
+*
+*           If m >= k, assume m >= n >= k
+*
+            CALL ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+         ELSE
+*
+*           If m < k, assume m = n
+*
+*           Shift the vectors which define the elementary reflectors one
+*           column to the right, and set the first row and column of Q
+*           to those of the unit matrix
+*
+            DO 20 J = M, 2, -1
+               A( 1, J ) = ZERO
+               DO 10 I = J + 1, M
+                  A( I, J ) = A( I, J-1 )
+   10          CONTINUE
+   20       CONTINUE
+            A( 1, 1 ) = ONE
+            DO 30 I = 2, M
+               A( I, 1 ) = ZERO
+   30       CONTINUE
+            IF( M.GT.1 ) THEN
+*
+*              Form Q(2:m,2:m)
+*
+               CALL ZUNGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                      LWORK, IINFO )
+            END IF
+         END IF
+      ELSE
+*
+*        Form P', determined by a call to ZGEBRD to reduce a k-by-n
+*        matrix
+*
+         IF( K.LT.N ) THEN
+*
+*           If k < n, assume k <= m <= n
+*
+            CALL ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+         ELSE
+*
+*           If k >= n, assume m = n
+*
+*           Shift the vectors which define the elementary reflectors one
+*           row downward, and set the first row and column of P' to
+*           those of the unit matrix
+*
+            A( 1, 1 ) = ONE
+            DO 40 I = 2, N
+               A( I, 1 ) = ZERO
+   40       CONTINUE
+            DO 60 J = 2, N
+               DO 50 I = J - 1, 2, -1
+                  A( I, J ) = A( I-1, J )
+   50          CONTINUE
+               A( 1, J ) = ZERO
+   60       CONTINUE
+            IF( N.GT.1 ) THEN
+*
+*              Form P'(2:n,2:n)
+*
+               CALL ZUNGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                      LWORK, IINFO )
+            END IF
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNGBR
+*
+      END
diff --git a/src/lib/lapack/zunghr.f b/src/lib/lapack/zunghr.f
new file mode 100644
index 00000000..fcf32abf
--- /dev/null
+++ b/src/lib/lapack/zunghr.f
@@ -0,0 +1,165 @@
+      SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            IHI, ILO, INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGHR generates a complex unitary matrix Q which is defined as the
+*  product of IHI-ILO elementary reflectors of order N, as returned by
+*  ZGEHRD:
+*
+*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  ILO     (input) INTEGER
+*  IHI     (input) INTEGER
+*          ILO and IHI must have the same values as in the previous call
+*          of ZGEHRD. Q is equal to the unit matrix except in the
+*          submatrix Q(ilo+1:ihi,ilo+1:ihi).
+*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by ZGEHRD.
+*          On exit, the N-by-N unitary matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,N).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEHRD.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= IHI-ILO.
+*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IINFO, J, LWKOPT, NB, NH
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNGQR
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NH = IHI - ILO
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( N.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+         INFO = -2
+      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         NB = ILAENV( 1, 'ZUNGQR', ' ', NH, NH, NH, -1 )
+         LWKOPT = MAX( 1, NH )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGHR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+*     Shift the vectors which define the elementary reflectors one
+*     column to the right, and set the first ilo and the last n-ihi
+*     rows and columns to those of the unit matrix
+*
+      DO 40 J = IHI, ILO + 1, -1
+         DO 10 I = 1, J - 1
+            A( I, J ) = ZERO
+   10    CONTINUE
+         DO 20 I = J + 1, IHI
+            A( I, J ) = A( I, J-1 )
+   20    CONTINUE
+         DO 30 I = IHI + 1, N
+            A( I, J ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      DO 60 J = 1, ILO
+         DO 50 I = 1, N
+            A( I, J ) = ZERO
+   50    CONTINUE
+         A( J, J ) = ONE
+   60 CONTINUE
+      DO 80 J = IHI + 1, N
+         DO 70 I = 1, N
+            A( I, J ) = ZERO
+   70    CONTINUE
+         A( J, J ) = ONE
+   80 CONTINUE
+*
+      IF( NH.GT.0 ) THEN
+*
+*        Generate Q(ilo+1:ihi,ilo+1:ihi)
+*
+         CALL ZUNGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+     $                WORK, LWORK, IINFO )
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNGHR
+*
+      END
diff --git a/src/lib/lapack/zungl2.f b/src/lib/lapack/zungl2.f
new file mode 100644
index 00000000..502411b4
--- /dev/null
+++ b/src/lib/lapack/zungl2.f
@@ -0,0 +1,136 @@
+      SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
+*  which is defined as the first m rows of a product of k elementary
+*  reflectors of order n
+*
+*        Q  =  H(k)' . . . H(2)' H(1)'
+*
+*  as returned by ZGELQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the i-th row must contain the vector which defines
+*          the elementary reflector H(i), for i = 1,2,...,k, as returned
+*          by ZGELQF in the first k rows of its array argument A.
+*          On exit, the m by n matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGELQF.
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension (M)
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE, ZERO
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
+     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            I, J, L
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLARF, ZSCAL
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGL2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 )
+     $   RETURN
+*
+      IF( K.LT.M ) THEN
+*
+*        Initialise rows k+1:m to rows of the unit matrix
+*
+         DO 20 J = 1, N
+            DO 10 L = K + 1, M
+               A( L, J ) = ZERO
+   10       CONTINUE
+            IF( J.GT.K .AND. J.LE.M )
+     $         A( J, J ) = ONE
+   20    CONTINUE
+      END IF
+*
+      DO 40 I = K, 1, -1
+*
+*        Apply H(i)' to A(i:m,i:n) from the right
+*
+         IF( I.LT.N ) THEN
+            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+            IF( I.LT.M ) THEN
+               A( I, I ) = ONE
+               CALL ZLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+     $                     DCONJG( TAU( I ) ), A( I+1, I ), LDA, WORK )
+            END IF
+            CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
+            CALL ZLACGV( N-I, A( I, I+1 ), LDA )
+         END IF
+         A( I, I ) = ONE - DCONJG( TAU( I ) )
+*
+*        Set A(i,1:i-1) to zero
+*
+         DO 30 L = 1, I - 1
+            A( I, L ) = ZERO
+   30    CONTINUE
+   40 CONTINUE
+      RETURN
+*
+*     End of ZUNGL2
+*
+      END
diff --git a/src/lib/lapack/zunglq.f b/src/lib/lapack/zunglq.f
new file mode 100644
index 00000000..ab4a018f
--- /dev/null
+++ b/src/lib/lapack/zunglq.f
@@ -0,0 +1,215 @@
+      SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
+*  which is defined as the first M rows of a product of K elementary
+*  reflectors of order N
+*
+*        Q  =  H(k)' . . . H(2)' H(1)'
+*
+*  as returned by ZGELQF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. N >= M.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. M >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the i-th row must contain the vector which defines
+*          the elementary reflector H(i), for i = 1,2,...,k, as returned
+*          by ZGELQF in the first k rows of its array argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGELQF.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,M).
+*          For optimum performance LWORK >= M*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit;
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNGL2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'ZUNGLQ', ' ', M, N, K, -1 )
+      LWKOPT = MAX( 1, M )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGLQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = M
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZUNGLQ', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = M
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGLQ', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the last block.
+*        The first kk rows are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+*        Set A(kk+1:m,1:kk) to zero.
+*
+         DO 20 J = 1, KK
+            DO 10 I = KK + 1, M
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the last or only block.
+*
+      IF( KK.LT.M )
+     $   CALL ZUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+     $                TAU( KK+1 ), WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = KI + 1, 1, -NB
+            IB = MIN( NB, K-I+1 )
+            IF( I+IB.LE.M ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL ZLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+     $                      LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H' to A(i+ib:m,i:n) from the right
+*
+               CALL ZLARFB( 'Right', 'Conjugate transpose', 'Forward',
+     $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
+     $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H' to columns i:n of current block
+*
+            CALL ZUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+*
+*           Set columns 1:i-1 of current block to zero
+*
+            DO 40 J = 1, I - 1
+               DO 30 L = I, I + IB - 1
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZUNGLQ
+*
+      END
diff --git a/src/lib/lapack/zungql.f b/src/lib/lapack/zungql.f
new file mode 100644
index 00000000..4232abea
--- /dev/null
+++ b/src/lib/lapack/zungql.f
@@ -0,0 +1,222 @@
+      SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
+*  which is defined as the last N columns of a product of K elementary
+*  reflectors of order M
+*
+*        Q  =  H(k) . . . H(2) H(1)
+*
+*  as returned by ZGEQLF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the (n-k+i)-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGEQLF in the last k columns of its array
+*          argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQLF.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+     $                   NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNG2L
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( N.EQ.0 ) THEN
+            LWKOPT = 1
+         ELSE
+            NB = ILAENV( 1, 'ZUNGQL', ' ', M, N, K, -1 )
+            LWKOPT = N*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+            INFO = -8
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGQL', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZUNGQL', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQL', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the first block.
+*        The last kk columns are handled by the block method.
+*
+         KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+*        Set A(m-kk+1:m,1:n-kk) to zero.
+*
+         DO 20 J = 1, N - KK
+            DO 10 I = M - KK + 1, M
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the first or only block.
+*
+      CALL ZUNG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = K - KK + 1, K, NB
+            IB = MIN( NB, K-I+1 )
+            IF( N-K+I.GT.1 ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i+ib-1) . . . H(i+1) H(i)
+*
+               CALL ZLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+     $                      A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+               CALL ZLARFB( 'Left', 'No transpose', 'Backward',
+     $                      'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+     $                      A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+     $                      WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H to rows 1:m-k+i+ib-1 of current block
+*
+            CALL ZUNG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
+     $                   TAU( I ), WORK, IINFO )
+*
+*           Set rows m-k+i+ib:m of current block to zero
+*
+            DO 40 J = N - K + I, N - K + I + IB - 1
+               DO 30 L = M - K + I + IB, M
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZUNGQL
+*
+      END
diff --git a/src/lib/lapack/zungqr.f b/src/lib/lapack/zungqr.f
new file mode 100644
index 00000000..bf5c6997
--- /dev/null
+++ b/src/lib/lapack/zungqr.f
@@ -0,0 +1,216 @@
+      SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INFO, K, LDA, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
+*  which is defined as the first N columns of a product of K elementary
+*  reflectors of order M
+*
+*        Q  =  H(1) H(2) . . . H(k)
+*
+*  as returned by ZGEQRF.
+*
+*  Arguments
+*  =========
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix Q. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix Q. M >= N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines the
+*          matrix Q. N >= K >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the i-th column must contain the vector which
+*          defines the elementary reflector H(i), for i = 1,2,...,k, as
+*          returned by ZGEQRF in the first k columns of its array
+*          argument A.
+*          On exit, the M-by-N matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The first dimension of the array A. LDA >= max(1,M).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQRF.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= max(1,N).
+*          For optimum performance LWORK >= N*NB, where NB is the
+*          optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument has an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY
+      INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+     $                   LWKOPT, NB, NBMIN, NX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNG2R
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. External Functions ..
+      INTEGER            ILAENV
+      EXTERNAL           ILAENV
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      NB = ILAENV( 1, 'ZUNGQR', ' ', M, N, K, -1 )
+      LWKOPT = MAX( 1, N )*NB
+      WORK( 1 ) = LWKOPT
+      LQUERY = ( LWORK.EQ.-1 )
+      IF( M.LT.0 ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+         INFO = -2
+      ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+         INFO = -3
+      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+         INFO = -5
+      ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+         INFO = -8
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGQR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.LE.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      NX = 0
+      IWS = N
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+*        Determine when to cross over from blocked to unblocked code.
+*
+         NX = MAX( 0, ILAENV( 3, 'ZUNGQR', ' ', M, N, K, -1 ) )
+         IF( NX.LT.K ) THEN
+*
+*           Determine if workspace is large enough for blocked code.
+*
+            LDWORK = N
+            IWS = LDWORK*NB
+            IF( LWORK.LT.IWS ) THEN
+*
+*              Not enough workspace to use optimal NB:  reduce NB and
+*              determine the minimum value of NB.
+*
+               NB = LWORK / LDWORK
+               NBMIN = MAX( 2, ILAENV( 2, 'ZUNGQR', ' ', M, N, K, -1 ) )
+            END IF
+         END IF
+      END IF
+*
+      IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+*        Use blocked code after the last block.
+*        The first kk columns are handled by the block method.
+*
+         KI = ( ( K-NX-1 ) / NB )*NB
+         KK = MIN( K, KI+NB )
+*
+*        Set A(1:kk,kk+1:n) to zero.
+*
+         DO 20 J = KK + 1, N
+            DO 10 I = 1, KK
+               A( I, J ) = ZERO
+   10       CONTINUE
+   20    CONTINUE
+      ELSE
+         KK = 0
+      END IF
+*
+*     Use unblocked code for the last or only block.
+*
+      IF( KK.LT.N )
+     $   CALL ZUNG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+     $                TAU( KK+1 ), WORK, IINFO )
+*
+      IF( KK.GT.0 ) THEN
+*
+*        Use blocked code
+*
+         DO 50 I = KI + 1, 1, -NB
+            IB = MIN( NB, K-I+1 )
+            IF( I+IB.LE.N ) THEN
+*
+*              Form the triangular factor of the block reflector
+*              H = H(i) H(i+1) . . . H(i+ib-1)
+*
+               CALL ZLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+     $                      A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+*              Apply H to A(i:m,i+ib:n) from the left
+*
+               CALL ZLARFB( 'Left', 'No transpose', 'Forward',
+     $                      'Columnwise', M-I+1, N-I-IB+1, IB,
+     $                      A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+     $                      LDA, WORK( IB+1 ), LDWORK )
+            END IF
+*
+*           Apply H to rows i:m of current block
+*
+            CALL ZUNG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
+     $                   IINFO )
+*
+*           Set rows 1:i-1 of current block to zero
+*
+            DO 40 J = I, I + IB - 1
+               DO 30 L = 1, I - 1
+                  A( L, J ) = ZERO
+   30          CONTINUE
+   40       CONTINUE
+   50    CONTINUE
+      END IF
+*
+      WORK( 1 ) = IWS
+      RETURN
+*
+*     End of ZUNGQR
+*
+      END
diff --git a/src/lib/lapack/zungtr.f b/src/lib/lapack/zungtr.f
new file mode 100644
index 00000000..5de7c109
--- /dev/null
+++ b/src/lib/lapack/zungtr.f
@@ -0,0 +1,184 @@
+      SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          UPLO
+      INTEGER            INFO, LDA, LWORK, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNGTR generates a complex unitary matrix Q which is defined as the
+*  product of n-1 elementary reflectors of order N, as returned by
+*  ZHETRD:
+*
+*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+*  Arguments
+*  =========
+*
+*  UPLO    (input) CHARACTER*1
+*          = 'U': Upper triangle of A contains elementary reflectors
+*                 from ZHETRD;
+*          = 'L': Lower triangle of A contains elementary reflectors
+*                 from ZHETRD.
+*
+*  N       (input) INTEGER
+*          The order of the matrix Q. N >= 0.
+*
+*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
+*          On entry, the vectors which define the elementary reflectors,
+*          as returned by ZHETRD.
+*          On exit, the N-by-N unitary matrix Q.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= N.
+*
+*  TAU     (input) COMPLEX*16 array, dimension (N-1)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZHETRD.
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK. LWORK >= N-1.
+*          For optimum performance LWORK >= (N-1)*NB, where NB is
+*          the optimal blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ZERO, ONE
+      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
+     $                   ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LQUERY, UPPER
+      INTEGER            I, IINFO, J, LWKOPT, NB
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNGQL, ZUNGQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LQUERY = ( LWORK.EQ.-1 )
+      UPPER = LSAME( UPLO, 'U' )
+      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+         INFO = -1
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -2
+      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+         INFO = -4
+      ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
+         INFO = -7
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( UPPER ) THEN
+            NB = ILAENV( 1, 'ZUNGQL', ' ', N-1, N-1, N-1, -1 )
+         ELSE
+            NB = ILAENV( 1, 'ZUNGQR', ' ', N-1, N-1, N-1, -1 )
+         END IF
+         LWKOPT = MAX( 1, N-1 )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNGTR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( N.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      IF( UPPER ) THEN
+*
+*        Q was determined by a call to ZHETRD with UPLO = 'U'
+*
+*        Shift the vectors which define the elementary reflectors one
+*        column to the left, and set the last row and column of Q to
+*        those of the unit matrix
+*
+         DO 20 J = 1, N - 1
+            DO 10 I = 1, J - 1
+               A( I, J ) = A( I, J+1 )
+   10       CONTINUE
+            A( N, J ) = ZERO
+   20    CONTINUE
+         DO 30 I = 1, N - 1
+            A( I, N ) = ZERO
+   30    CONTINUE
+         A( N, N ) = ONE
+*
+*        Generate Q(1:n-1,1:n-1)
+*
+         CALL ZUNGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+      ELSE
+*
+*        Q was determined by a call to ZHETRD with UPLO = 'L'.
+*
+*        Shift the vectors which define the elementary reflectors one
+*        column to the right, and set the first row and column of Q to
+*        those of the unit matrix
+*
+         DO 50 J = N, 2, -1
+            A( 1, J ) = ZERO
+            DO 40 I = J + 1, N
+               A( I, J ) = A( I, J-1 )
+   40       CONTINUE
+   50    CONTINUE
+         A( 1, 1 ) = ONE
+         DO 60 I = 2, N
+            A( I, 1 ) = ZERO
+   60    CONTINUE
+         IF( N.GT.1 ) THEN
+*
+*           Generate Q(2:n,2:n)
+*
+            CALL ZUNGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+     $                   LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNGTR
+*
+      END
diff --git a/src/lib/lapack/zunm2r.f b/src/lib/lapack/zunm2r.f
new file mode 100644
index 00000000..7d4c067a
--- /dev/null
+++ b/src/lib/lapack/zunm2r.f
@@ -0,0 +1,201 @@
+      SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNM2R overwrites the general complex m-by-n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'C', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'C',
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'C': apply Q' (Conjugate transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZGEQRF in the first k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQRF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the m-by-n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      COMPLEX*16         AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNM2R', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JC = 1
+      ELSE
+         MI = M
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) or H(i)' is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = TAU( I )
+         ELSE
+            TAUI = DCONJG( TAU( I ) )
+         END IF
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC,
+     $               WORK )
+         A( I, I ) = AII
+   10 CONTINUE
+      RETURN
+*
+*     End of ZUNM2R
+*
+      END
diff --git a/src/lib/lapack/zunmbr.f b/src/lib/lapack/zunmbr.f
new file mode 100644
index 00000000..b32ce338
--- /dev/null
+++ b/src/lib/lapack/zunmbr.f
@@ -0,0 +1,288 @@
+      SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+     $                   LDC, WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS, VECT
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
+*  with
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'C':      Q**H * C       C * Q**H
+*
+*  If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
+*  with
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      P * C          C * P
+*  TRANS = 'C':      P**H * C       C * P**H
+*
+*  Here Q and P**H are the unitary matrices determined by ZGEBRD when
+*  reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
+*  and P**H are defined as products of elementary reflectors H(i) and
+*  G(i) respectively.
+*
+*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
+*  order of the unitary matrix Q or P**H that is applied.
+*
+*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
+*  if nq >= k, Q = H(1) H(2) . . . H(k);
+*  if nq < k, Q = H(1) H(2) . . . H(nq-1).
+*
+*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
+*  if k < nq, P = G(1) G(2) . . . G(k);
+*  if k >= nq, P = G(1) G(2) . . . G(nq-1).
+*
+*  Arguments
+*  =========
+*
+*  VECT    (input) CHARACTER*1
+*          = 'Q': apply Q or Q**H;
+*          = 'P': apply P or P**H.
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q, Q**H, P or P**H from the Left;
+*          = 'R': apply Q, Q**H, P or P**H from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q or P;
+*          = 'C':  Conjugate transpose, apply Q**H or P**H.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          If VECT = 'Q', the number of columns in the original
+*          matrix reduced by ZGEBRD.
+*          If VECT = 'P', the number of rows in the original
+*          matrix reduced by ZGEBRD.
+*          K >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                                (LDA,min(nq,K)) if VECT = 'Q'
+*                                (LDA,nq)        if VECT = 'P'
+*          The vectors which define the elementary reflectors H(i) and
+*          G(i), whose products determine the matrices Q and P, as
+*          returned by ZGEBRD.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If VECT = 'Q', LDA >= max(1,nq);
+*          if VECT = 'P', LDA >= max(1,min(nq,K)).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (min(nq,K))
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i) or G(i) which determines Q or P, as returned
+*          by ZGEBRD in the array argument TAUQ or TAUP.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
+*          or P*C or P**H*C or C*P or C*P**H.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M);
+*          if N = 0 or M = 0, LWORK >= 1.
+*          For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
+*          and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
+*          optimal blocksize. (NB = 0 if M = 0 or N = 0.)
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZUNMLQ, ZUNMQR
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      APPLYQ = LSAME( VECT, 'Q' )
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q or P and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         NW = 0
+      END IF
+      IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -2
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -3
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -5
+      ELSE IF( K.LT.0 ) THEN
+         INFO = -6
+      ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
+     $         ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
+     $          THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -13
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( NW.GT.0 ) THEN
+            IF( APPLYQ ) THEN
+               IF( LEFT ) THEN
+                  NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M-1, N, M-1,
+     $                 -1 )
+               ELSE
+                  NB = ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N-1, N-1,
+     $                 -1 )
+               END IF
+            ELSE
+               IF( LEFT ) THEN
+                  NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M-1, N, M-1,
+     $                 -1 )
+               ELSE
+                  NB = ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N-1, N-1,
+     $                 -1 )
+               END IF
+            END IF
+            LWKOPT = MAX( 1, NW*NB )
+         ELSE
+            LWKOPT = 1
+         END IF
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMBR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 )
+     $   RETURN
+*
+      IF( APPLYQ ) THEN
+*
+*        Apply Q
+*
+         IF( NQ.GE.K ) THEN
+*
+*           Q was determined by a call to ZGEBRD with nq >= k
+*
+            CALL ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, IINFO )
+         ELSE IF( NQ.GT.1 ) THEN
+*
+*           Q was determined by a call to ZGEBRD with nq < k
+*
+            IF( LEFT ) THEN
+               MI = M - 1
+               NI = N
+               I1 = 2
+               I2 = 1
+            ELSE
+               MI = M
+               NI = N - 1
+               I1 = 1
+               I2 = 2
+            END IF
+            CALL ZUNMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+     $                   C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+         END IF
+      ELSE
+*
+*        Apply P
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'C'
+         ELSE
+            TRANST = 'N'
+         END IF
+         IF( NQ.GT.K ) THEN
+*
+*           P was determined by a call to ZGEBRD with nq > k
+*
+            CALL ZUNMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, IINFO )
+         ELSE IF( NQ.GT.1 ) THEN
+*
+*           P was determined by a call to ZGEBRD with nq <= k
+*
+            IF( LEFT ) THEN
+               MI = M - 1
+               NI = N
+               I1 = 2
+               I2 = 1
+            ELSE
+               MI = M
+               NI = N - 1
+               I1 = 1
+               I2 = 2
+            END IF
+            CALL ZUNMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
+     $                   TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+         END IF
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNMBR
+*
+      END
diff --git a/src/lib/lapack/zunml2.f b/src/lib/lapack/zunml2.f
new file mode 100644
index 00000000..cced4a77
--- /dev/null
+++ b/src/lib/lapack/zunml2.f
@@ -0,0 +1,205 @@
+      SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNML2 overwrites the general complex m-by-n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'C', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'C',
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k)' . . . H(2)' H(1)'
+*
+*  as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'C': apply Q' (Conjugate transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZGELQF in the first k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGELQF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the m-by-n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      COMPLEX*16         ONE
+      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JC, MI, NI, NQ
+      COMPLEX*16         AII, TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLACGV, ZLARF
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNML2', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JC = 1
+      ELSE
+         MI = M
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) or H(i)' is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = DCONJG( TAU( I ) )
+         ELSE
+            TAUI = TAU( I )
+         END IF
+         IF( I.LT.NQ )
+     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
+         AII = A( I, I )
+         A( I, I ) = ONE
+         CALL ZLARF( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, JC ),
+     $               LDC, WORK )
+         A( I, I ) = AII
+         IF( I.LT.NQ )
+     $      CALL ZLACGV( NQ-I, A( I, I+1 ), LDA )
+   10 CONTINUE
+      RETURN
+*
+*     End of ZUNML2
+*
+      END
diff --git a/src/lib/lapack/zunmlq.f b/src/lib/lapack/zunmlq.f
new file mode 100644
index 00000000..b1708757
--- /dev/null
+++ b/src/lib/lapack/zunmlq.f
@@ -0,0 +1,267 @@
+      SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMLQ overwrites the general complex M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'C':      Q**H * C       C * Q**H
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(k)' . . . H(2)' H(1)'
+*
+*  as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'C':  Conjugate transpose, apply Q**H.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZGELQF in the first k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGELQF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNML2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.  NB may be at most NBMAX, where NBMAX
+*        is used to define the local array T.
+*
+         NB = MIN( NBMAX, ILAENV( 1, 'ZUNMLQ', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMLQ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMLQ', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'C'
+         ELSE
+            TRANST = 'N'
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i) H(i+1) . . . H(i+ib-1)
+*
+            CALL ZLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
+     $                   LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL ZLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
+     $                   A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK,
+     $                   LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNMLQ
+*
+      END
diff --git a/src/lib/lapack/zunmqr.f b/src/lib/lapack/zunmqr.f
new file mode 100644
index 00000000..f9b1e98f
--- /dev/null
+++ b/src/lib/lapack/zunmqr.f
@@ -0,0 +1,260 @@
+      SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMQR overwrites the general complex M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'C':      Q**H * C       C * Q**H
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'C':  Conjugate transpose, apply Q**H.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension (LDA,K)
+*          The i-th column must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZGEQRF in the first k columns of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A.
+*          If SIDE = 'L', LDA >= max(1,M);
+*          if SIDE = 'R', LDA >= max(1,N).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZGEQRF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+     $                   LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARFB, ZLARFT, ZUNM2R
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = N
+      ELSE
+         NQ = N
+         NW = M
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+         INFO = -7
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -10
+      ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+         INFO = -12
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+*
+*        Determine the block size.  NB may be at most NBMAX, where NBMAX
+*        is used to define the local array T.
+*
+         NB = MIN( NBMAX, ILAENV( 1, 'ZUNMQR', SIDE // TRANS, M, N, K,
+     $        -1 ) )
+         LWKOPT = MAX( 1, NW )*NB
+         WORK( 1 ) = LWKOPT
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMQR', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+         WORK( 1 ) = 1
+         RETURN
+      END IF
+*
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMQR', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+     $                IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+         ELSE
+            MI = M
+            IC = 1
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i) H(i+1) . . . H(i+ib-1)
+*
+            CALL ZLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
+     $                   LDA, TAU( I ), T, LDT )
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL ZLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
+     $                   IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
+     $                   WORK, LDWORK )
+   10    CONTINUE
+      END IF
+      WORK( 1 ) = LWKOPT
+      RETURN
+*
+*     End of ZUNMQR
+*
+      END
diff --git a/src/lib/lapack/zunmr3.f b/src/lib/lapack/zunmr3.f
new file mode 100644
index 00000000..111c1c95
--- /dev/null
+++ b/src/lib/lapack/zunmr3.f
@@ -0,0 +1,212 @@
+      SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMR3 overwrites the general complex m by n matrix C with
+*
+*        Q * C  if SIDE = 'L' and TRANS = 'N', or
+*
+*        Q'* C  if SIDE = 'L' and TRANS = 'C', or
+*
+*        C * Q  if SIDE = 'R' and TRANS = 'N', or
+*
+*        C * Q' if SIDE = 'R' and TRANS = 'C',
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q' from the Left
+*          = 'R': apply Q or Q' from the Right
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N': apply Q  (No transpose)
+*          = 'C': apply Q' (Conjugate transpose)
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing
+*          the meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZTZRZF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZTZRZF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the m-by-n matrix C.
+*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace) COMPLEX*16 array, dimension
+*                                   (N) if SIDE = 'L',
+*                                   (M) if SIDE = 'R'
+*
+*  INFO    (output) INTEGER
+*          = 0: successful exit
+*          < 0: if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      LOGICAL            LEFT, NOTRAN
+      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
+      COMPLEX*16         TAUI
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      EXTERNAL           LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARZ
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          DCONJG, MAX
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+*
+*     NQ is the order of Q
+*
+      IF( LEFT ) THEN
+         NQ = M
+      ELSE
+         NQ = N
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+     $         ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMR3', -INFO )
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+     $   RETURN
+*
+      IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
+         I1 = 1
+         I2 = K
+         I3 = 1
+      ELSE
+         I1 = K
+         I2 = 1
+         I3 = -1
+      END IF
+*
+      IF( LEFT ) THEN
+         NI = N
+         JA = M - L + 1
+         JC = 1
+      ELSE
+         MI = M
+         JA = N - L + 1
+         IC = 1
+      END IF
+*
+      DO 10 I = I1, I2, I3
+         IF( LEFT ) THEN
+*
+*           H(i) or H(i)' is applied to C(i:m,1:n)
+*
+            MI = M - I + 1
+            IC = I
+         ELSE
+*
+*           H(i) or H(i)' is applied to C(1:m,i:n)
+*
+            NI = N - I + 1
+            JC = I
+         END IF
+*
+*        Apply H(i) or H(i)'
+*
+         IF( NOTRAN ) THEN
+            TAUI = TAU( I )
+         ELSE
+            TAUI = DCONJG( TAU( I ) )
+         END IF
+         CALL ZLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAUI,
+     $               C( IC, JC ), LDC, WORK )
+*
+   10 CONTINUE
+*
+      RETURN
+*
+*     End of ZUNMR3
+*
+      END
diff --git a/src/lib/lapack/zunmrz.f b/src/lib/lapack/zunmrz.f
new file mode 100644
index 00000000..c7637050
--- /dev/null
+++ b/src/lib/lapack/zunmrz.f
@@ -0,0 +1,296 @@
+      SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                   WORK, LWORK, INFO )
+*
+*  -- LAPACK routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      CHARACTER          SIDE, TRANS
+      INTEGER            INFO, K, L, LDA, LDC, LWORK, M, N
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZUNMRZ overwrites the general complex M-by-N matrix C with
+*
+*                  SIDE = 'L'     SIDE = 'R'
+*  TRANS = 'N':      Q * C          C * Q
+*  TRANS = 'C':      Q**H * C       C * Q**H
+*
+*  where Q is a complex unitary matrix defined as the product of k
+*  elementary reflectors
+*
+*        Q = H(1) H(2) . . . H(k)
+*
+*  as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N
+*  if SIDE = 'R'.
+*
+*  Arguments
+*  =========
+*
+*  SIDE    (input) CHARACTER*1
+*          = 'L': apply Q or Q**H from the Left;
+*          = 'R': apply Q or Q**H from the Right.
+*
+*  TRANS   (input) CHARACTER*1
+*          = 'N':  No transpose, apply Q;
+*          = 'C':  Conjugate transpose, apply Q**H.
+*
+*  M       (input) INTEGER
+*          The number of rows of the matrix C. M >= 0.
+*
+*  N       (input) INTEGER
+*          The number of columns of the matrix C. N >= 0.
+*
+*  K       (input) INTEGER
+*          The number of elementary reflectors whose product defines
+*          the matrix Q.
+*          If SIDE = 'L', M >= K >= 0;
+*          if SIDE = 'R', N >= K >= 0.
+*
+*  L       (input) INTEGER
+*          The number of columns of the matrix A containing
+*          the meaningful part of the Householder reflectors.
+*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+*  A       (input) COMPLEX*16 array, dimension
+*                               (LDA,M) if SIDE = 'L',
+*                               (LDA,N) if SIDE = 'R'
+*          The i-th row must contain the vector which defines the
+*          elementary reflector H(i), for i = 1,2,...,k, as returned by
+*          ZTZRZF in the last k rows of its array argument A.
+*          A is modified by the routine but restored on exit.
+*
+*  LDA     (input) INTEGER
+*          The leading dimension of the array A. LDA >= max(1,K).
+*
+*  TAU     (input) COMPLEX*16 array, dimension (K)
+*          TAU(i) must contain the scalar factor of the elementary
+*          reflector H(i), as returned by ZTZRZF.
+*
+*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
+*          On entry, the M-by-N matrix C.
+*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+*  LDC     (input) INTEGER
+*          The leading dimension of the array C. LDC >= max(1,M).
+*
+*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
+*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+*  LWORK   (input) INTEGER
+*          The dimension of the array WORK.
+*          If SIDE = 'L', LWORK >= max(1,N);
+*          if SIDE = 'R', LWORK >= max(1,M).
+*          For optimum performance LWORK >= N*NB if SIDE = 'L', and
+*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+*          blocksize.
+*
+*          If LWORK = -1, then a workspace query is assumed; the routine
+*          only calculates the optimal size of the WORK array, returns
+*          this value as the first entry of the WORK array, and no error
+*          message related to LWORK is issued by XERBLA.
+*
+*  INFO    (output) INTEGER
+*          = 0:  successful exit
+*          < 0:  if INFO = -i, the i-th argument had an illegal value
+*
+*  Further Details
+*  ===============
+*
+*  Based on contributions by
+*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      INTEGER            NBMAX, LDT
+      PARAMETER          ( NBMAX = 64, LDT = NBMAX+1 )
+*     ..
+*     .. Local Scalars ..
+      LOGICAL            LEFT, LQUERY, NOTRAN
+      CHARACTER          TRANST
+      INTEGER            I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC,
+     $                   LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+*     ..
+*     .. Local Arrays ..
+      COMPLEX*16         T( LDT, NBMAX )
+*     ..
+*     .. External Functions ..
+      LOGICAL            LSAME
+      INTEGER            ILAENV
+      EXTERNAL           LSAME, ILAENV
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           XERBLA, ZLARZB, ZLARZT, ZUNMR3
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          MAX, MIN
+*     ..
+*     .. Executable Statements ..
+*
+*     Test the input arguments
+*
+      INFO = 0
+      LEFT = LSAME( SIDE, 'L' )
+      NOTRAN = LSAME( TRANS, 'N' )
+      LQUERY = ( LWORK.EQ.-1 )
+*
+*     NQ is the order of Q and NW is the minimum dimension of WORK
+*
+      IF( LEFT ) THEN
+         NQ = M
+         NW = MAX( 1, N )
+      ELSE
+         NQ = N
+         NW = MAX( 1, M )
+      END IF
+      IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+         INFO = -1
+      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+         INFO = -2
+      ELSE IF( M.LT.0 ) THEN
+         INFO = -3
+      ELSE IF( N.LT.0 ) THEN
+         INFO = -4
+      ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+         INFO = -5
+      ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+     $         ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+         INFO = -6
+      ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+         INFO = -8
+      ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+         INFO = -11
+      END IF
+*
+      IF( INFO.EQ.0 ) THEN
+         IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+            LWKOPT = 1
+*
+*           Determine the block size.  NB may be at most NBMAX, where
+*           NBMAX is used to define the local array T.
+*
+            NB = MIN( NBMAX, ILAENV( 1, 'ZUNMRQ', SIDE // TRANS, M, N,
+     $                               K, -1 ) )
+            LWKOPT = NW*NB
+         END IF
+         WORK( 1 ) = LWKOPT
+*
+         IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+            INFO = -13
+         END IF
+      END IF
+*
+      IF( INFO.NE.0 ) THEN
+         CALL XERBLA( 'ZUNMRZ', -INFO )
+         RETURN
+      ELSE IF( LQUERY ) THEN
+         RETURN
+      END IF
+*
+*     Quick return if possible
+*
+      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+         RETURN
+      END IF
+*
+*     Determine the block size.  NB may be at most NBMAX, where NBMAX
+*     is used to define the local array T.
+*
+      NB = MIN( NBMAX, ILAENV( 1, 'ZUNMRQ', SIDE // TRANS, M, N, K,
+     $     -1 ) )
+      NBMIN = 2
+      LDWORK = NW
+      IF( NB.GT.1 .AND. NB.LT.K ) THEN
+         IWS = NW*NB
+         IF( LWORK.LT.IWS ) THEN
+            NB = LWORK / LDWORK
+            NBMIN = MAX( 2, ILAENV( 2, 'ZUNMRQ', SIDE // TRANS, M, N, K,
+     $              -1 ) )
+         END IF
+      ELSE
+         IWS = NW
+      END IF
+*
+      IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+*        Use unblocked code
+*
+         CALL ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+     $                WORK, IINFO )
+      ELSE
+*
+*        Use blocked code
+*
+         IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+     $       ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+            I1 = 1
+            I2 = K
+            I3 = NB
+         ELSE
+            I1 = ( ( K-1 ) / NB )*NB + 1
+            I2 = 1
+            I3 = -NB
+         END IF
+*
+         IF( LEFT ) THEN
+            NI = N
+            JC = 1
+            JA = M - L + 1
+         ELSE
+            MI = M
+            IC = 1
+            JA = N - L + 1
+         END IF
+*
+         IF( NOTRAN ) THEN
+            TRANST = 'C'
+         ELSE
+            TRANST = 'N'
+         END IF
+*
+         DO 10 I = I1, I2, I3
+            IB = MIN( NB, K-I+1 )
+*
+*           Form the triangular factor of the block reflector
+*           H = H(i+ib-1) . . . H(i+1) H(i)
+*
+            CALL ZLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
+     $                   TAU( I ), T, LDT )
+*
+            IF( LEFT ) THEN
+*
+*              H or H' is applied to C(i:m,1:n)
+*
+               MI = M - I + 1
+               IC = I
+            ELSE
+*
+*              H or H' is applied to C(1:m,i:n)
+*
+               NI = N - I + 1
+               JC = I
+            END IF
+*
+*           Apply H or H'
+*
+            CALL ZLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+     $                   IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
+     $                   LDC, WORK, LDWORK )
+   10    CONTINUE
+*
+      END IF
+*
+      WORK( 1 ) = LWKOPT
+*
+      RETURN
+*
+*     End of ZUNMRZ
+*
+      END